lac : 87168c0fd8f9ddf9c62a1a75c45c4ba09dea2574

     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: #include <gc/gc.h>
    28: 
    29: #ifdef __GNUC__
    30: #define _noreturn __attribute__((noreturn))
    31: #else
    32: #define _noreturn
    33: #endif
    34: 
    35: 
    36: /*
    37:  * Basic Types.
    38:  */
    39: 
    40: struct env;
    41: typedef struct env lenv_t;
    42: typedef uintptr_t lreg_t;
    43: 
    44: 
    45: /*
    46:  * LREG/Type model.
    47:  *
    48:  * We require GC-allocated memory to be 8-byte aligned, so that we can
    49:  * use the least significant three bits for storing type information
    50:  * (up to seven types). Extended types (types whose id cannot be
    51:  * decoded in three bits) are encoded via the EXTT-type LREG, whose
    52:  * PTR points to a TREG, capable of storing a full object and a
    53:  * bigger tag.
    54:  */
    55: 
    56: enum lreg_type
    57:   {
    58:     LREG_CONS = 0,  /* Cons cells. */
    59:     LREG_SYMBOL,    /* Symbols. */
    60:     LREG_STRING,    /* String. */
    61:     LREG_LLPROC,    /* C procedures. */
    62:     LREG_LAMBDA,    /* Lambda procedures. */
    63:     LREG_MACRO,     /* Macro procedures. */
    64:     LREG_NIL,       /* NIL. */
    65:     LREG_EXTT,      /* External Type. */
    66:     /* EXTTYs */
    67:     LREG_INTEGER,   /* Integers, Fixed External type. */
    68:     LREG_AVAIL,
    69:     LREG_TYPES=256
    70:   };
    71: #define LREG_TYPE_MASK 0x7
    72: 
    73: 
    74: /*
    75:  * EXTTY handling.
    76:  */
    77: 
    78: struct treg_hdr {
    79: 	unsigned type;
    80: 	size_t   size;
    81: 	void *ptr;
    82: };
    83: 
    84: typedef struct {
    85:   char *name;
    86:   void (*print)(FILE *fd, lreg_t lr);
    87:   int (*equal)(lreg_t arg1, lreg_t arg2);
    88: } lac_exttype_t;
    89: 
    90: static inline lreg_t lreg_raw(void *ptr, unsigned type)
    91: {
    92:   return (lreg_t)((uintptr_t)ptr) | type;
    93: }
    94: 
    95: static inline void *lreg_raw_ptr(lreg_t lr)
    96: {
    97:   return (void *)((uintptr_t)lr & ~LREG_TYPE_MASK);
    98: }
    99: 
   100: static inline uintptr_t lreg_raw_type(lreg_t lr)
   101: {
   102:   return (uintptr_t)lr & LREG_TYPE_MASK;
   103: }
   104: 
   105: static inline unsigned lreg_type(lreg_t lr)
   106: {
   107:   unsigned raw_type = lr & LREG_TYPE_MASK;
   108: 
   109:   switch(raw_type) {
   110:   case LREG_EXTT:
   111:     return ((struct treg_hdr *)lreg_raw_ptr(lr))->type;
   112:   default:
   113:     return raw_type;
   114:   }
   115: }
   116: 
   117: static inline void *lreg_ptr(lreg_t lr)
   118: {
   119:   unsigned raw_type = lr & LREG_TYPE_MASK;
   120:   void *lreg_ptr = lreg_raw_ptr(lr);
   121: 
   122:   switch(raw_type) {
   123:   case LREG_EXTT:
   124:     return ((struct treg_hdr *)lreg_ptr)->ptr;
   125:   default:
   126:     return lreg_ptr;
   127:   }
   128: }
   129: 
   130: void raise_exception(char *, lreg_t) _noreturn;
   131: 
   132: lenv_t *lac_envalloc(void);
   133: lenv_t * lac_init(void);
   134: extern void *GC_malloc(size_t);
   135: 
   136: static inline void *lac_alloc(size_t size)
   137: {
   138: 	return GC_MALLOC(size);
   139: }
   140: 
   141: static inline void *lac_alloc_fini(size_t size,
   142: 				   void (*fn)(void*,void*), void *opq)
   143: {
   144: 	void *obj = GC_MALLOC(size);
   145: 	GC_REGISTER_FINALIZER_IGNORE_SELF(obj, fn, opq, 0, 0);
   146: 	return obj;
   147: }
   148: 
   149: void lac_error_print (FILE * f);
   150: lreg_t lac_eval (lreg_t lr, lenv_t *env);
   151: 
   152: 
   153: struct cons
   154: {
   155:   lreg_t a;
   156:   lreg_t d;
   157: };
   158: 
   159: static inline struct cons *
   160: get_cons(lreg_t lr)
   161: {
   162:   if (lreg_raw_type(lr) == LREG_CONS)
   163:     return (struct cons *)lreg_raw_ptr(lr);
   164:   raise_exception("not a cons", lr);
   165: }
   166: 
   167: static inline lreg_t lac_string_box(char *s)
   168: {
   169:   return lreg_raw(GC_strdup(s), LREG_STRING);
   170: }
   171: 
   172: 
   173: /*
   174:  * Embedded procedures
   175:  */
   176: 
   177: #define LAC_API __attribute__((aligned(16)))
   178: typedef lreg_t (*lac_function_t)(lreg_t args, lenv_t *argenv, lenv_t *env);
   179: 
   180: 
   181: /*
   182:  * Extension
   183:  */
   184: 
   185: void lac_extproc_register(lenv_t *env, const char *sym, lac_function_t f);
   186: 
   187: int lac_extty_register(unsigned typeno, lac_exttype_t *extty);
   188: lreg_t lac_extty_box(unsigned typeno, void *ptr, size_t size);
   189: size_t lac_extty_unbox(lreg_t lr, void **ptr);
   190: unsigned lac_extty_get_type(lreg_t lr);
   191: size_t lac_extty_get_size(lreg_t lr);
   192: int lac_extty_print(FILE * fd, lreg_t lr);
   193: 
   194: 
   195: /*
   196:  * Lisp Machine
   197:  */
   198: 
   199: #define NIL lreg_raw(0,LREG_NIL)
   200: extern lreg_t sym_true;
   201: extern lreg_t sym_false;
   202: extern lreg_t sym_quote;
   203: extern lreg_t sym_quasiquote;
   204: extern lreg_t sym_unquote;
   205: extern lreg_t sym_splice;
   206: extern lreg_t sym_rest;
   207: 
   208: #define car(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->a)
   209: #define cdr(_lr) ((_lr) == NIL ? NIL : get_cons(_lr)->d)
   210: #define rplaca(_lr, _a) do { get_cons(_lr)->a = (_a); } while(0)
   211: #define rplacd(_lr, _d) do { get_cons(_lr)->d = (_d); } while(0)
   212: lreg_t evargs(lreg_t list, lenv_t *env);
   213: lreg_t eval(lreg_t list, lenv_t *env);
   214: lreg_t apply(lreg_t proc, lreg_t args, lenv_t *env);
   215: lreg_t cons(lreg_t a, lreg_t b);
   216: lreg_t intern_symbol(char *s);
   217: 
   218: #define _ERROR_AND_RET(err)	\
   219:   do {				\
   220:     raise_exception(err, NIL);	\
   221:   } while ( 0 )
   222: 
   223: #define __EXPECT_MIN_ARGS__(args, num)					\
   224:   do {									\
   225:     int i;								\
   226:     for ( i = 0; i < num; tmp = cdr(tmp), i++ )				\
   227:       if ( tmp == NIL )							\
   228: 	_ERROR_AND_RET("Not enough arguments");	\
   229:   } while ( 0 )
   230: 
   231: #define _EXPECT_MIN_ARGS(args, num)					\
   232:   do {									\
   233:     lreg_t tmp = args;							\
   234:     __EXPECT_MIN_ARGS__(args, num);					\
   235:   } while ( 0 )
   236: 
   237: #define _EXPECT_ARGS(args, num)						\
   238:   do {									\
   239:     lreg_t tmp = args;							\
   240:     __EXPECT_MIN_ARGS__(args, num);					\
   241:     if ( tmp != NIL )							\
   242:       _ERROR_AND_RET("Too Many arguments");				\
   243:   } while ( 0 )
   244: 
   245: #define ARGEVAL(_lr, _e) ((_e) == NULL ? _lr : eval((_lr), (_e)))
   246: 
   247: #define LAC_DEFINE_TYPE_PFUNC(typename, typeno)				\
   248:   LAC_API static lreg_t proc_##typename##p (lreg_t args, lenv_t *argenv, lenv_t *env) \
   249: {									\
   250:   _EXPECT_ARGS(args, 1);						\
   251:   lreg_t arg1 = ARGEVAL(car(args), argenv);				\
   252:   if ( lreg_type(arg1) == typeno )					\
   253:     return sym_true;							\
   254:   else									\
   255:     return sym_false;							\
   256: }
   257: #define LAC_TYPE_PFUNC(typename) proc_##typename##p
   258: 
   259: /*
   260:  * Exception handling.
   261:  * Simple SJLJ for now(?).
   262:  */
   263: 
   264: #include <setjmp.h>
   265: #include <stdlib.h>
   266: 
   267: struct _lac_xcpt {
   268:   sigjmp_buf buf;
   269:   struct _lac_xcpt *next;
   270: };
   271: 
   272: /* Per thread. Correct but ugh. */
   273: extern __thread struct _lac_xcpt *_lac_xcpt;
   274: extern __thread char *_lac_xcpt_msg;
   275: extern __thread lreg_t _lac_xcpt_reg;
   276: 
   277: #define lac_errlreg() _lac_xcpt_reg
   278: #define lac_errmsg() _lac_xcpt_msg
   279: 
   280: #define lac_on_error(_b) do {					\
   281:     struct _lac_xcpt *p = malloc(sizeof(struct _lac_xcpt));	\
   282:     p->next = _lac_xcpt;					\
   283:     _lac_xcpt = p;						\
   284:     if ( sigsetjmp(p->buf, 1) != 0 ) {				\
   285:       { _b };							\
   286:     }								\
   287:   } while(0)
   288: 
   289: #define lac_off_error() do {			\
   290:     struct _lac_xcpt *p = _lac_xcpt;		\
   291:     _lac_xcpt = p->next;			\
   292:     free(p);					\
   293:   } while(0)
   294: 
   295: 
   296: /*
   297:  * Representations
   298:  */
   299: 
   300: lreg_t sexpr_eval_string(char *s, lenv_t *env);
   301: lreg_t sexpr_parse_string(char *s, lreg_t (*fn)(lreg_t,void*), void *opq);
   302: lreg_t sexpr_parse_file(FILE *f, lreg_t (*fn)(lreg_t,void*), void *opq);
   303: void sexpr_fprint(FILE *f, lreg_t lr);
   304: 
   305: #endif /* LACONIC_H */

Generated by git2html.