lac : 7cc6411db5df89cc00c2bd2d2991a51aee594a06

     1: /*
     2:    lac -- a lisp interpreter library
     3:    Copyright (C) 2010 Gianluca Guida
     4: 
     5:    This program is free software; you can redistribute it and/or modify
     6:    it under the terms of the GNU General Public License as published by
     7:    the Free Software Foundation; either version 2 of the License, or
     8:    (at your option) any later version.
     9: 
    10:    This program is distributed in the hope that it will be useful,
    11:    but WITHOUT ANY WARRANTY; without even the implied warranty of
    12:    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    13:    GNU General Public License for more details.
    14: 
    15:    You should have received a copy of the GNU General Public License along
    16:    with this program; if not, write to the Free Software Foundation, Inc.,
    17:    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
    18: */
    19: 
    20: #ifndef __LACONIC_H
    21: #define __LACONIC_H
    22: 
    23: #include <stdio.h>
    24: #include <stdint.h>
    25: #include <inttypes.h>
    26: 
    27: #ifdef __GNUC__
    28: #define _noreturn __attribute__((noreturn))
    29: #else
    30: #define _noreturn
    31: #endif
    32: 
    33: 
    34: /*
    35:  * Basic Types.
    36:  */
    37: 
    38: struct env;
    39: typedef struct env lenv_t;
    40: typedef uintptr_t lreg_t;
    41: 
    42: 
    43: /*
    44:  * LREG/Type model.
    45:  *
    46:  * We require GC-allocated memory to be 8-byte aligned, so that we can
    47:  * use the least significant three bits for storing type information
    48:  * (up to seven types). Extended types (types whose id cannot be
    49:  * decoded in three bits) are encoded via the EXTT-type LREG, whose
    50:  * PTR points to a TREG, capable of storing a full object and a
    51:  * bigger tag.
    52:  */
    53: 
    54: enum lreg_type
    55:   {
    56:     LREG_CONS = 0,  /* Cons cells. */
    57:     LREG_SYMBOL,    /* Symbols. */
    58:     LREG_STRING,    /* String. */
    59:     LREG_LLPROC,    /* C procedures. */
    60:     LREG_LAMBDA,    /* Lambda procedures. */
    61:     LREG_MACRO,     /* Macro procedures. */
    62:     LREG_NIL,       /* NIL. */
    63:     LREG_EXTT,      /* External Type. */
    64:     /* EXTTYs */
    65:     LREG_INTEGER,   /* Integers, Fixed External type. */
    66:     LREG_AVAIL,
    67:     LREG_TYPES=256
    68:   };
    69: #define LREG_TYPE_MASK 0x7
    70: 
    71: 
    72: /*
    73:  * EXTTY handling.
    74:  */
    75: 
    76: struct treg_hdr {
    77: 	unsigned type;
    78: 	size_t   size;
    79: 	void *ptr;
    80: };
    81: 
    82: typedef struct {
    83:   char *name;
    84:   void (*print)(FILE *fd, lreg_t lr);
    85:   lreg_t (*equal)(lreg_t arg1, lreg_t arg2);
    86: } lac_exttype_t;
    87: 
    88: static inline lreg_t lreg_raw(void *ptr, unsigned type)
    89: {
    90:   return (lreg_t)((uintptr_t)ptr) | type;
    91: }
    92: 
    93: static inline void *lreg_raw_ptr(lreg_t lr)
    94: {
    95:   return (void *)((uintptr_t)lr & ~LREG_TYPE_MASK);
    96: }
    97: 
    98: static inline uintptr_t lreg_raw_type(lreg_t lr)
    99: {
   100:   return (uintptr_t)lr & LREG_TYPE_MASK;
   101: }
   102: 
   103: static inline unsigned lreg_type(lreg_t lr)
   104: {
   105:   unsigned raw_type = lr & LREG_TYPE_MASK;
   106: 
   107:   switch(raw_type) {
   108:   case LREG_EXTT:
   109:     return ((struct treg_hdr *)lreg_raw_ptr(lr))->type;
   110:   default:
   111:     return raw_type;
   112:   }
   113: }
   114: 
   115: static inline void *lreg_ptr(lreg_t lr)
   116: {
   117:   unsigned raw_type = lr & LREG_TYPE_MASK;
   118:   void *lreg_ptr = lreg_raw_ptr(lr);
   119: 
   120:   switch(raw_type) {
   121:   case LREG_EXTT:
   122:     return ((struct treg_hdr *)lreg_ptr)->ptr;
   123:   default:
   124:     return lreg_ptr;
   125:   }
   126: }
   127: 
   128: void raise_exception(char *, lreg_t) _noreturn;
   129: 
   130: lenv_t *lac_envalloc(void);
   131: lenv_t * lac_init(void);
   132: extern void *GC_malloc(size_t);
   133: #define lac_alloc GC_malloc
   134: 
   135: struct cons
   136: {
   137:   lreg_t a;
   138:   lreg_t d;
   139: };
   140: 
   141: static inline struct cons *
   142: get_cons(lreg_t lr)
   143: {
   144:   if (lreg_raw_type(lr) == LREG_CONS)
   145:     return (struct cons *)lreg_raw_ptr(lr);
   146:   raise_exception("not a cons", lr);
   147: }
   148: 
   149: 
   150: /*
   151:  * Embedded procedures
   152:  */
   153: 
   154: #define LAC_API __attribute__((aligned(16)))
   155: typedef lreg_t (*lac_function_t)(lreg_t args, lenv_t *argenv, lenv_t *env);
   156: 
   157: 
   158: /*
   159:  * Extension
   160:  */
   161: 
   162: void lac_extproc_register(lenv_t *env, const char *sym, lac_function_t f);
   163: 
   164: int lac_extty_register(unsigned typeno, lac_exttype_t *extty);
   165: lreg_t lac_extty_box(unsigned typeno, void *ptr, size_t size);
   166: size_t lac_extty_unbox(lreg_t lr, void **ptr);
   167: unsigned lac_extty_get_type(lreg_t lr);
   168: size_t lac_extty_get_size(lreg_t lr);
   169: int lac_extty_print(FILE * fd, lreg_t lr);
   170: 
   171: 
   172: /*
   173:  * Lisp Machine
   174:  */
   175: 
   176: #define NIL lreg_raw(0,LREG_NIL)
   177: extern lreg_t sym_true;
   178: extern lreg_t sym_false;
   179: extern lreg_t sym_quote;
   180: extern lreg_t sym_quasiquote;
   181: extern lreg_t sym_unquote;
   182: extern lreg_t sym_splice;
   183: extern lreg_t sym_rest;
   184: 
   185: #define car(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->a)
   186: #define cdr(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->d)
   187: #define rplaca(_lr, _a) do { get_cons(_lr)->a = (_a); } while(0)
   188: #define rplacd(_lr, _d) do { get_cons(_lr)->d = (_d); } while(0)
   189: lreg_t evargs(lreg_t list, lenv_t *env);
   190: lreg_t eval(lreg_t list, lenv_t *env);
   191: lreg_t apply(lreg_t proc, lreg_t args, lenv_t *env);
   192: lreg_t cons(lreg_t a, lreg_t b);
   193: lreg_t intern_symbol(char *s);
   194: 
   195: #define _ERROR_AND_RET(err)	\
   196:   do {				\
   197:     raise_exception(err, NIL);	\
   198:   } while ( 0 )
   199: 
   200: #define __EXPECT_MIN_ARGS__(args, num)					\
   201:   do {									\
   202:     int i;								\
   203:     for ( i = 0; i < num; tmp = cdr(tmp), i++ )				\
   204:       if ( tmp == NIL )							\
   205: 	_ERROR_AND_RET("Not enough arguments");	\
   206:   } while ( 0 )
   207: 
   208: #define _EXPECT_MIN_ARGS(args, num)					\
   209:   do {									\
   210:     lreg_t tmp = args;							\
   211:     __EXPECT_MIN_ARGS__(args, num);					\
   212:   } while ( 0 )
   213: 
   214: #define _EXPECT_ARGS(args, num)						\
   215:   do {									\
   216:     lreg_t tmp = args;							\
   217:     __EXPECT_MIN_ARGS__(args, num);					\
   218:     if ( tmp != NIL )							\
   219:       _ERROR_AND_RET("Too Many arguments");				\
   220:   } while ( 0 )
   221: 
   222: #define LAC_DEFINE_TYPE_PFUNC(typename, typeno)				\
   223:   LAC_API static lreg_t proc_##typename##p (lreg_t args, lenv_t *argenv, lenv_t *env) \
   224: {									\
   225:   _EXPECT_ARGS(args, 1);						\
   226:   lreg_t arg1 = ARGEVAL(car(args), argenv);				\
   227:   if ( lreg_type(arg1) == typeno )					\
   228:     return sym_true;							\
   229:   else									\
   230:     return sym_false;							\
   231: }
   232: #define LAC_TYPE_PFUNC(typename) proc_##typename##p
   233: 
   234: /*
   235:  * Exception handling.
   236:  * Simple SJLJ for now(?).
   237:  */
   238: 
   239: #include <setjmp.h>
   240: #include <stdlib.h>
   241: 
   242: struct _lac_xcpt {
   243:   sigjmp_buf buf;
   244:   struct _lac_xcpt *next;
   245: };
   246: 
   247: /* Per thread. Correct but ugh. */
   248: extern __thread struct _lac_xcpt *_lac_xcpt;
   249: extern __thread char *_lac_xcpt_msg;
   250: extern __thread lreg_t _lac_xcpt_reg;
   251: 
   252: #define lac_errlreg() _lac_xcpt_reg
   253: #define lac_errmsg() _lac_xcpt_msg
   254: 
   255: #define lac_on_error(_b) do {					\
   256:     struct _lac_xcpt *p = malloc(sizeof(struct _lac_xcpt));	\
   257:     p->next = _lac_xcpt;					\
   258:     _lac_xcpt = p;						\
   259:     if ( sigsetjmp(p->buf, 1) != 0 ) {				\
   260:       { _b };							\
   261:     }								\
   262:   } while(0)
   263: 
   264: #define lac_off_error() do {			\
   265:     struct _lac_xcpt *p = _lac_xcpt;		\
   266:     _lac_xcpt = p->next;			\
   267:     free(p);					\
   268:   } while(0)
   269: 
   270: 
   271: /*
   272:  * Representations
   273:  */
   274: 
   275: void sexpr_read_start(FILE *f, void **yyscan);
   276: int sexpr_read(lreg_t *res, void *yyscan);
   277: void sexpr_read_stop(void *yyscan);
   278: void sexpr_print(FILE *f, lreg_t lr);  
   279: 
   280: #endif /* LACONIC_H */

Generated by git2html.