├── doc ├── .gitignore ├── SConscript └── wisp-guide.txt ├── .gitignore ├── test ├── stress.wisp ├── SConscript ├── eq-test.wisp └── wisp_tests.c ├── lib ├── lisp.h ├── SConscript ├── wisp.h ├── mem.h ├── str.h ├── number.h ├── common.h ├── detach.h ├── cons.h ├── vector.h ├── mem.c ├── number.c ├── object.h ├── symtab.h ├── str.c ├── reader.h ├── eval.h ├── symtab.c ├── common.c ├── detach.c ├── cons.c ├── hashtab.h ├── vector.c ├── object.c ├── hashtab.c ├── lisp_math.c ├── eval.c ├── reader.c └── lisp.c ├── wisplib ├── test.wisp ├── examples.wisp ├── sandbox.wisp ├── memoize.wisp ├── point-free.wisp ├── set.wisp ├── hash.wisp ├── vector.wisp ├── math.wisp └── list.wisp ├── INSTALL ├── README ├── TODO ├── UNLICENSE ├── core.wisp ├── wisp.c └── SConstruct /doc/.gitignore: -------------------------------------------------------------------------------- 1 | wisp-guide.html 2 | -------------------------------------------------------------------------------- /doc/SConscript: -------------------------------------------------------------------------------- 1 | Import('normal') 2 | 3 | if not normal.has_key('noasciidoc'): 4 | normal.AsciiDoc('wisp-guide.html', 'wisp-guide.txt') 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.os 3 | *.so 4 | *.a 5 | wisp 6 | wisp_tests 7 | 8 | # SCons stuff 9 | .sconsign.dblite 10 | config.log 11 | .sconf_temp/ 12 | -------------------------------------------------------------------------------- /test/stress.wisp: -------------------------------------------------------------------------------- 1 | ;;; Runs tests from the Wisp side 2 | 3 | ;; Stress test 4 | (require 'examples) 5 | (progn 6 | (fib 20) 7 | (fib 25) 8 | (fib 30)) 9 | -------------------------------------------------------------------------------- /lib/lisp.h: -------------------------------------------------------------------------------- 1 | /* lisp.h - exposes the function that installs all cfuncs */ 2 | #ifndef LISP_H 3 | #define LISP_H 4 | 5 | void lisp_init (); 6 | 7 | #endif /* LISP_H */ 8 | -------------------------------------------------------------------------------- /wisplib/test.wisp: -------------------------------------------------------------------------------- 1 | ;;; Unit testing functions 2 | 3 | (defun assert-exit (val) 4 | "If argument is nil, exit interpreter with error." 5 | (if (not val) 6 | (exit -1))) 7 | 8 | (provide 'test) 9 | -------------------------------------------------------------------------------- /wisplib/examples.wisp: -------------------------------------------------------------------------------- 1 | ;;; Small example wisp functions 2 | 3 | (defun fib (n) 4 | "Return nth Fibonacci number." 5 | (if (<= n 2) 1 6 | (+ (fib (- n 1)) (fib (- n 2))))) 7 | 8 | (provide 'examples) 9 | -------------------------------------------------------------------------------- /wisplib/sandbox.wisp: -------------------------------------------------------------------------------- 1 | ;;; sandbox.wisp - removes "dangerous" functions for executing untrusted code 2 | 3 | ;; malicious code could make this large and crash the interpreter 4 | (setq max-eval-depth nil) 5 | 6 | (provide 'sandbox) 7 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | You can put the wisp binary anywhere on your system, but it will still 2 | need to access this source directory to get the definitions it 3 | needs. You can indicate where this directory is to Wisp with the 4 | environmental variable WISPROOT. For example, 5 | 6 | export WISPROOT=~/src/wisp 7 | 8 | That's it for now. 9 | -------------------------------------------------------------------------------- /test/SConscript: -------------------------------------------------------------------------------- 1 | Import('normal') 2 | 3 | check = normal.Program(target = 'wisp_tests', 4 | source = 'wisp_tests.c', 5 | LIBS = ['gmp', 'wisp'], 6 | LIBPATH = normal['LIBPATH'] + ['../lib']) 7 | 8 | check_alias = normal.Alias('check', check, check[0].path) 9 | normal.AlwaysBuild(check_alias) 10 | -------------------------------------------------------------------------------- /lib/SConscript: -------------------------------------------------------------------------------- 1 | Import('normal') 2 | 3 | libsrc = Split("""common.c cons.c eval.c hashtab.c lisp.c lisp_math.c 4 | mem.c number.c object.c reader.c str.c symtab.c 5 | vector.c detach.c""") 6 | 7 | normal.Library(target = 'libwisp', 8 | source = libsrc) 9 | 10 | normal.SharedLibrary(target = 'libwisp', 11 | source = libsrc) 12 | -------------------------------------------------------------------------------- /lib/wisp.h: -------------------------------------------------------------------------------- 1 | /* wisp.h - main include for software accessing wisp C API */ 2 | #ifndef WISP_H 3 | #define WISP_H 4 | 5 | /* Should include all the necessary header files for doing stuff. */ 6 | 7 | #include "cons.h" 8 | #include "symtab.h" 9 | #include "object.h" 10 | #include "str.h" 11 | #include "eval.h" 12 | #include "common.h" 13 | #include "lisp.h" 14 | #include "reader.h" 15 | #include "number.h" 16 | #include "vector.h" 17 | 18 | #endif /* LIST_H */ 19 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | See the user guide in doc/ for complete information on Wisp. If 2 | AsciiDoc and SCons is installed, you can build it with "scons". Or you 3 | can just look at the very readable documentation source text. 4 | 5 | If you just want to see it without poking around documentation, you 6 | can build it right now by running "scons" here. Then simply execute 7 | wisp. Try it with rlwrap for better command line editing. 8 | 9 | See INSTALL for quick info on installing Wisp. 10 | -------------------------------------------------------------------------------- /wisplib/memoize.wisp: -------------------------------------------------------------------------------- 1 | ;;; Memoization definitions 2 | (require 'hash) 3 | 4 | ;; this isn't working 100% yet 5 | (defun memoize (f) 6 | "Install memoize wrapper on given function." 7 | (setq *table* (make-hash-table 2000)) 8 | (set f (list 'lambda '(&rest vars) 9 | (list 'if '(hget *table* vars) 10 | '(hget *table* vars) 11 | (list 'hput '*table* 'vars 12 | (list 'apply (value f) 'vars))) 13 | '(hget *table* vars)))) 14 | 15 | (provide 'memoize) 16 | -------------------------------------------------------------------------------- /wisplib/point-free.wisp: -------------------------------------------------------------------------------- 1 | ;;; Point-free functions 2 | 3 | (defun partial (f &rest pargs) 4 | "Create partial application of function." 5 | (list 'lambda '(&rest args) 6 | (list 'apply f (list 'append (list 'quote pargs) 'args)))) 7 | 8 | (defun comp-build (f &rest fs) 9 | "Helper function for comp function composition." 10 | (if (nullp fs) 11 | (list 'apply f 'args) 12 | (list f (apply comp-build fs)))) 13 | 14 | (defun comp (&rest fs) 15 | "Compose a number of functions." 16 | (list 'lambda '(&rest args) 17 | (apply comp-build fs))) 18 | 19 | (provide 'point-free) 20 | -------------------------------------------------------------------------------- /lib/mem.h: -------------------------------------------------------------------------------- 1 | /* mem.h - generic obstack library */ 2 | #ifndef MEM_H 3 | #define MEM_H 4 | 5 | #include 6 | 7 | typedef struct mmanager 8 | { 9 | size_t osize; 10 | void **stack, **base; 11 | size_t size; 12 | void (*clearf) (void *o); 13 | } mmanager_t; 14 | 15 | /* Creates a new memory manager. */ 16 | mmanager_t *mm_create (size_t osize, void (*clear_func) (void *o)); 17 | 18 | /* Free a memory manager */ 19 | void mm_destroy (mmanager_t * mm); 20 | 21 | /* Allocate and free a new object */ 22 | void *mm_alloc (mmanager_t * mm); 23 | void mm_free (mmanager_t * mm, void *o); 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * Key 2 | + import 3 | * normal 4 | - unimportant 5 | 6 | * Development 7 | * start using a real bug tracker 8 | 9 | + Core 10 | * loop detection needed in places 11 | * advanced quoting 12 | * more advanced let binding 13 | - closures 14 | - symbol aliasing 15 | - undefined variables. all are defined to nil atm 16 | 17 | * CFUNC Define 18 | * maths 19 | * cond/and/or 20 | * file i/o w/ lisp reader/writer 21 | * string ops 22 | 23 | * Lisp Define 24 | * alist, plist 25 | * map 26 | * macroexpand 27 | * more ... 28 | 29 | * Documentation 30 | * probably should document the undefined ones too, to plan ahead 31 | - man page 32 | 33 | * Test suite 34 | * add more tests! 35 | -------------------------------------------------------------------------------- /wisplib/set.wisp: -------------------------------------------------------------------------------- 1 | ;;; Set functions 2 | 3 | ;; Member was already defined so it could be used by require 4 | 5 | (defun union (a b) 6 | "Combine two sets by the union set function." 7 | (if (nullp a) 8 | b 9 | (if (member (car a) b) 10 | (union (cdr a) b) 11 | (cons (car a) (union (cdr a) b))))) 12 | 13 | (defun adjoin (el lst) 14 | "Add element to set if it's not already a member of that set." 15 | (if (member el lst) 16 | lst 17 | (cons el lst))) 18 | 19 | (defun intersection (a b) 20 | "Return set containing elements only present in both sets." 21 | (if (nullp a) 22 | nil 23 | (if (member (car a) b) 24 | (cons (car a) (intersection (cdr a) b)) 25 | (intersection (cdr a) b)))) 26 | 27 | (provide 'set) 28 | -------------------------------------------------------------------------------- /lib/str.h: -------------------------------------------------------------------------------- 1 | #ifndef STR_H 2 | #define STR_H 3 | 4 | #include "object.h" 5 | 6 | typedef struct str 7 | { 8 | char *raw; 9 | char *print; 10 | size_t len; 11 | } str_t; 12 | 13 | /* Must be called before any other functions. */ 14 | void str_init (); 15 | 16 | /* Memory management. */ 17 | str_t *str_create (); 18 | void str_destroy (); 19 | object_t *c_str (char *str, size_t len); 20 | object_t *c_strs (char *str); 21 | 22 | void str_genp (object_t * o); 23 | 24 | /* String operators */ 25 | object_t *str_cat (object_t * ao, object_t * bo); 26 | 27 | #define OSTR(o) (((str_t *) OVAL(o))->raw) 28 | #define OSTRLEN(o) (((str_t *) OVAL(o))->len) 29 | #define OSTRP(o) (str_genp (o), ((str_t *) OVAL(o))->print) 30 | 31 | uint32_t str_hash (object_t * o); 32 | 33 | #endif /* STR_H */ 34 | -------------------------------------------------------------------------------- /lib/number.h: -------------------------------------------------------------------------------- 1 | #ifndef NUMBER_H 2 | #define NUMBER_H 3 | 4 | #include 5 | #include "object.h" 6 | 7 | object_t *c_ints (char *n); 8 | object_t *c_int (int n); 9 | object_t *c_floats (char *f); 10 | object_t *c_float (double f); 11 | 12 | /* get native numbers from number objects */ 13 | int into2int (object_t * into); 14 | double floato2float (object_t * floato); 15 | 16 | #define OINT(o) ((mpz_t *) OVAL(o)) 17 | #define OFLOAT(o) ((mpf_t *) OVAL(o)) 18 | #define DINT(o) (*((mpz_t *) OVAL(o))) 19 | #define DFLOAT(o) (*((mpf_t *) OVAL(o))) 20 | 21 | #define INTP(o) (o->type == INT) 22 | #define FLOATP(o) (o->type == FLOAT) 23 | #define NUMP(o) (INTP (o) || FLOATP (o)) 24 | 25 | uint32_t int_hash (object_t * o); 26 | uint32_t float_hash (object_t * o); 27 | 28 | #endif /* NUMBER_H */ 29 | -------------------------------------------------------------------------------- /lib/common.h: -------------------------------------------------------------------------------- 1 | /* common.h - generic functions for use anywhere */ 2 | #ifndef COMMON_H 3 | #define COMMON_H 4 | 5 | #include 6 | 7 | /* Wrapper for malloc() and realloc(). Will exit() the program on error. */ 8 | void *xmalloc (size_t size); 9 | void *xrealloc (void *p, size_t size); 10 | void xfree (void *p); 11 | 12 | /* Define a strdup() since it's not always there. */ 13 | char *xstrdup (char *str); 14 | 15 | /* Concatentate path strings. */ 16 | char *pathcat (char *prefix, char *path); 17 | 18 | /* Handle strings from the lexer. The returned string is from xmalloc(). */ 19 | char *process_str (char *str); 20 | 21 | /* Create a new string that can be read back in again by the lexer. */ 22 | char *unprocess_str (char *str); 23 | 24 | void error (char *str); 25 | 26 | #endif /* COMMON_H */ 27 | -------------------------------------------------------------------------------- /wisplib/hash.wisp: -------------------------------------------------------------------------------- 1 | ;;; Hash table definitions 2 | 3 | ;; this currently uses closed-hashing, but it would be better to 4 | ;; change this to open hashing 5 | 6 | (defun make-hash-table (size) 7 | "Create a new hash table." 8 | (list (make-vector size nil) size)) 9 | 10 | (defun hget (ht key) 11 | "Get value stored for given key." 12 | (let ((r nil) 13 | (ind (% (hash key) (cadr ht)))) 14 | (while (vget (car ht) ind) 15 | (if (equal (car (vget (car ht) ind)) key) 16 | (setq r (cdr (vget (car ht) ind)))) 17 | (setq ind (1+ ind))) 18 | r)) 19 | 20 | (defun hput (ht key val) 21 | "Set value for given key." 22 | (let ((ind (% (hash key) (cadr ht)))) 23 | (while (vget (car ht) ind) 24 | (if (equal (car (vget (car ht) ind)) o) 25 | (setq lst nil)) 26 | (setq ind (1+ ind))) 27 | (vset (car ht) ind (cons key val)))) 28 | 29 | (provide 'hash) 30 | -------------------------------------------------------------------------------- /test/eq-test.wisp: -------------------------------------------------------------------------------- 1 | ;;; Test equality functions 2 | 3 | (require 'test) 4 | 5 | ;; eq 6 | (assert-exit (eq 'a 'a)) 7 | (assert-exit (eq 'b 'b)) 8 | (assert-exit (not (eq 'a 'b))) 9 | (assert-exit (not (eq 10 10))) 10 | 11 | (let ((var 10)) 12 | (assert-exit (eq var var))) 13 | 14 | ;; eql 15 | (assert-exit (eql 100 100)) 16 | (assert-exit (eql 10 10)) 17 | (assert-exit (eql 10.1 10.1)) 18 | 19 | (assert-exit (not (eql 10 100))) 20 | 21 | ;; equal 22 | (assert-exit (equal '(a b c) '(a b c))) 23 | (assert-exit (equal '(a (b) c) '(a (b) c))) 24 | (assert-exit (equal '(a (b 10) c) '(a (b 10) c))) 25 | (assert-exit (equal '(a (b 10) nil c) '(a (b 10) nil c))) 26 | (assert-exit (equal '(a (b 10) (10.7 nil) c) '(a (b 10) (10.7 nil) c))) 27 | 28 | (assert-exit (not (equal '(a (b 10) (10.6 nil) c) '(a (b 10) (10.7 nil) c)))) 29 | (assert-exit (not (equal '(a (b 10) (10.6 nil) c) '(a (10) (10.7 nil) c)))) 30 | -------------------------------------------------------------------------------- /lib/detach.h: -------------------------------------------------------------------------------- 1 | #ifndef DETACH_H 2 | #define DETACH_H 3 | 4 | #include 5 | #include "object.h" 6 | #include "reader.h" 7 | 8 | typedef struct detach 9 | { 10 | int in, out; 11 | pid_t proc; 12 | reader_t *read; 13 | } detach_t; 14 | 15 | /* Creation and destruction */ 16 | object_t *c_detach (object_t * o); 17 | detach_t *detach_create (); 18 | void detach_destroy (object_t * o); 19 | 20 | /* Basic type functions */ 21 | uint8_t detach_hash (object_t * o); 22 | void detach_print (object_t * o); 23 | 24 | /* Info on parent process. */ 25 | extern object_t *parent_detach; 26 | 27 | /* lisp-space functions */ 28 | object_t *lisp_detach (object_t * lst); 29 | object_t *lisp_receive (object_t * lst); 30 | object_t *lisp_send (object_t * lst); 31 | 32 | #define OPROC(o) (((detach_t *) OVAL (o))->proc); 33 | #define OREAD(o) (((detach_t *) OVAL (o))->read); 34 | #define DETACHP(o) (o->type == DETACH) 35 | 36 | #endif /* DETACH_H */ 37 | -------------------------------------------------------------------------------- /wisplib/vector.wisp: -------------------------------------------------------------------------------- 1 | ;;; Vector functions 2 | 3 | (defun vconcat (vec &rest vecs) 4 | "Concatentate any number of vectors." 5 | (if (nullp vecs) 6 | vec 7 | (vconcat2 vec (apply vconcat vecs)))) 8 | 9 | (defun vsplice (vmain start end vins) 10 | "Insert vector over subsection of vector, returning new vector." 11 | (vconcat 12 | (if (= start 0) [] 13 | (vsub vmain 0 (1- start))) 14 | vins 15 | (if (= end (vlength vmain)) [] 16 | (vsub vmain (1+ end))))) 17 | 18 | (defun vfunc (vec &rest args) 19 | "General vector function that does it all-in-one." 20 | (let ((narg (length args))) 21 | (cond 22 | ((>= narg 3) (throw 'wrong-number-of-arguments args)) 23 | ((= 0 narg) vec) 24 | ; vget 25 | ((and (= 1 narg) (listp (car args))) 26 | (vsub vec (caar args) (cadar args))) 27 | ((and (= 1 narg)) (vget vec (car args))) 28 | ; vset 29 | ((listp (car args)) (vsplice vec (caar args) (cadar args) (cadr args))) 30 | (t (vset vec (car args) (cadr args)))))) 31 | 32 | (provide 'vector) 33 | -------------------------------------------------------------------------------- /lib/cons.h: -------------------------------------------------------------------------------- 1 | /* cons.h - cons cell and list functions */ 2 | #ifndef CONS_H 3 | #define CONS_H 4 | 5 | #include "object.h" 6 | 7 | typedef struct cons 8 | { 9 | object_t *car; 10 | object_t *cdr; 11 | } cons_t; 12 | 13 | /* Must be called before any other functions. */ 14 | void cons_init (); 15 | 16 | /* Memory management */ 17 | cons_t *cons_create (); 18 | void cons_destroy (cons_t * c); 19 | 20 | /* list operators */ 21 | object_t *req_length (object_t * lst, object_t * thr, int n); /* exact */ 22 | object_t *reqm_length (object_t * lst, object_t * thr, int n); /* min */ 23 | object_t *reqx_length (object_t * lst, object_t * thr, int n); /* max */ 24 | int is_func_form (object_t * lst); 25 | int is_var_list (object_t * lst); 26 | 27 | #define CAR(o) ((cons_t *) OVAL(o))->car 28 | #define CDR(o) ((cons_t *) OVAL(o))->cdr 29 | 30 | #define LISTP(o) (o->type == CONS || o == NIL) 31 | #define PAIRP(o) (o->type == CONS && !LISTP(CDR(o))) 32 | 33 | /* Determine if list is proper. */ 34 | object_t *properlistp (object_t * t); 35 | 36 | uint32_t cons_hash (object_t * o); 37 | 38 | #endif /* CONS_H */ 39 | -------------------------------------------------------------------------------- /lib/vector.h: -------------------------------------------------------------------------------- 1 | #ifndef VECTOR_H 2 | #define VECTOR_H 3 | 4 | #include 5 | #include "object.h" 6 | 7 | typedef struct vector 8 | { 9 | object_t **v; 10 | size_t len; 11 | } vector_t; 12 | 13 | /* standard object functions */ 14 | void vector_init (); 15 | vector_t *vector_create (); 16 | void vector_destroy (vector_t * o); 17 | 18 | /* General vector creation. */ 19 | object_t *c_vec (size_t len, object_t * init); 20 | 21 | /* Convert list to vector */ 22 | object_t *list2vector (object_t * lst); 23 | 24 | /* Access objects in a vector. */ 25 | void vset (object_t * vo, size_t i, object_t * val); 26 | object_t *vget (object_t * vo, size_t i); 27 | object_t *vset_check (object_t * vo, object_t * io, object_t * val); 28 | object_t *vget_check (object_t * vo, object_t * io); 29 | 30 | /* Vector concatenation, creating a new vector. */ 31 | object_t *vector_concat (object_t * a, object_t * b); 32 | 33 | /* Subsection of vector, returning a new vector. */ 34 | object_t *vector_sub (object_t * vo, int start, int end); 35 | 36 | /* Print a vector */ 37 | void vec_print (object_t * vo); 38 | 39 | #define VECTORP(o) ((o)->type == VECTOR) 40 | 41 | #define VLENGTH(o) (((vector_t *) OVAL(o))->len) 42 | 43 | uint32_t vector_hash (object_t * o); 44 | 45 | #endif /* VECTOR_H */ 46 | -------------------------------------------------------------------------------- /wisplib/math.wisp: -------------------------------------------------------------------------------- 1 | ;;; Extra math definitions 2 | 3 | (defun 1+ (n) 4 | "Return argument plus one." 5 | (+ n 1)) 6 | 7 | (defun 1- (n) 8 | "Return argument minus one." 9 | (- n 1)) 10 | 11 | (defun min (n &rest ns) 12 | "Return smallest argument." 13 | (cond 14 | ((nullp ns) n) 15 | ((= (length ns) 1) (if (< n (car ns)) n (car ns))) 16 | (t (min n (apply min ns))))) 17 | 18 | (defun max (n &rest ns) 19 | "Return largest argument." 20 | (cond 21 | ((nullp ns) n) 22 | ((= (length ns) 1) (if (> n (car ns)) n (car ns))) 23 | (t (max n (apply max ns))))) 24 | 25 | (defun abs (x) 26 | "Return absolute value of number." 27 | (if (> x 0) x 28 | (- x))) 29 | 30 | (defun nth-root (b n) 31 | "Return nth root of b." 32 | (if (< b 0) 33 | (throw 'domain-error b) 34 | (let ((x (/ b 2.0))) 35 | (while (> (abs (- (expt x n) b)) 0.00000001) 36 | (setq x (* (/ 1.0 n) (+ (* (1- n) x) (/ b (expt x (1- n))))))) 37 | x))) 38 | 39 | (defun sqrt (b) 40 | "Square root of a number." 41 | (nth-root b 2)) 42 | 43 | (defun expt (b p) 44 | "Return the exponential." 45 | (cond 46 | ((< p 0) (/ 1 (expt b (- p)))) 47 | ((= p 0) 1) 48 | ((< p 1) (nth-root b (/ 1 p))) 49 | (t (* b (expt b (1- p)))))) 50 | 51 | (provide 'math) 52 | -------------------------------------------------------------------------------- /UNLICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | -------------------------------------------------------------------------------- /lib/mem.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "common.h" 3 | #include "mem.h" 4 | 5 | void mm_fill_stack (mmanager_t * mm) 6 | { 7 | uint8_t *p = xmalloc ((mm->size - (mm->stack - mm->base)) * mm->osize); 8 | for (; mm->stack < mm->base + mm->size; mm->stack++, p += mm->osize) 9 | { 10 | mm->clearf (p); 11 | *(mm->stack) = (void *) p; 12 | } 13 | mm->stack--; 14 | } 15 | 16 | void mm_resize_stack (mmanager_t * mm) 17 | { 18 | mm->size *= 2; 19 | size_t count = mm->stack - mm->base; 20 | mm->base = xrealloc (mm->base, mm->size * sizeof (void *)); 21 | mm->stack = mm->base + count; 22 | } 23 | 24 | mmanager_t *mm_create (size_t osize, void (*clear_func) (void *o)) 25 | { 26 | mmanager_t *mm = xmalloc (sizeof (mmanager_t)); 27 | mm->osize = osize; 28 | mm->clearf = clear_func; 29 | mm->size = 1024; 30 | mm->stack = mm->base = xmalloc (sizeof (void *) * mm->size); 31 | mm_fill_stack (mm); 32 | return mm; 33 | } 34 | 35 | void mm_destroy (mmanager_t * mm) 36 | { 37 | xfree (mm->stack); 38 | xfree (mm); 39 | } 40 | 41 | void *mm_alloc (mmanager_t * mm) 42 | { 43 | if (mm->stack == mm->base) 44 | mm_fill_stack (mm); 45 | void *p = *(mm->stack); 46 | mm->stack--; 47 | return p; 48 | } 49 | 50 | void mm_free (mmanager_t * mm, void *o) 51 | { 52 | mm->stack++; 53 | if (mm->stack == mm->base + mm->size) 54 | mm_resize_stack (mm); 55 | *(mm->stack) = o; 56 | mm->clearf (o); 57 | } 58 | -------------------------------------------------------------------------------- /lib/number.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "object.h" 5 | #include "number.h" 6 | 7 | object_t *c_ints (char *nstr) 8 | { 9 | object_t *o = obj_create (INT); 10 | mpz_t *z = OVAL (o); 11 | mpz_init (*z); 12 | mpz_set_str (*z, nstr, 10); 13 | return o; 14 | } 15 | 16 | object_t *c_int (int n) 17 | { 18 | object_t *o = obj_create (INT); 19 | mpz_t *z = OVAL (o); 20 | mpz_init (*z); 21 | mpz_set_ui (*z, n); 22 | return o; 23 | } 24 | 25 | object_t *c_floats (char *fstr) 26 | { 27 | object_t *o = obj_create (FLOAT); 28 | mpf_t *f = OVAL (o); 29 | mpf_init2 (*f, 256); 30 | mpf_set_str (*f, fstr, 10); 31 | return o; 32 | } 33 | 34 | object_t *c_float (double d) 35 | { 36 | object_t *o = obj_create (FLOAT); 37 | mpf_t *f = OVAL (o); 38 | mpf_init2 (*f, 64); 39 | mpf_set_d (*f, d); 40 | return o; 41 | } 42 | 43 | int into2int (object_t * into) 44 | { 45 | return mpz_get_si (DINT (into)); 46 | } 47 | 48 | double floato2float (object_t * floato) 49 | { 50 | return mpf_get_d (DFLOAT (floato)); 51 | } 52 | 53 | uint32_t int_hash (object_t * o) 54 | { 55 | char *str = mpz_get_str (NULL, 16, DINT (o)); 56 | uint32_t h = hash (str, strlen (str)); 57 | free (str); 58 | return h; 59 | } 60 | 61 | uint32_t float_hash (object_t * o) 62 | { 63 | char *str = mpf_get_str (NULL, NULL, 16, 0, DFLOAT (o)); 64 | uint32_t h = hash (str, strlen (str)); 65 | free (str); 66 | return h; 67 | } 68 | -------------------------------------------------------------------------------- /lib/object.h: -------------------------------------------------------------------------------- 1 | /* objects.h - functions for manipulation of objects */ 2 | #ifndef OBJECT_H 3 | #define OBJECT_H 4 | 5 | #include 6 | 7 | typedef enum types 8 | { INT, FLOAT, STRING, SYMBOL, CONS, VECTOR, CFUNC, SPECIAL, DETACH } type_t; 9 | 10 | typedef union obval 11 | { 12 | void *val; 13 | struct object *(*fval) (struct object *); 14 | } obval_t; 15 | 16 | typedef struct object 17 | { 18 | type_t type; 19 | unsigned int refs; 20 | obval_t uval; 21 | } object_t; 22 | 23 | typedef object_t *(*cfunc_t) (object_t *); 24 | 25 | #define OVAL(o) ((o)->uval.val) 26 | #define FVAL(o) ((o)->uval.fval) 27 | 28 | /* Must be called before any other functions. */ 29 | void object_init (); 30 | 31 | /* Print an arbitrary object to stdout */ 32 | void obj_print (object_t * o, int newline); 33 | 34 | /* Object creation */ 35 | object_t *obj_create (type_t type); 36 | object_t *c_cons (object_t * car, object_t * cdr); 37 | object_t *c_cfunc (cfunc_t f); 38 | object_t *c_special (cfunc_t f); 39 | void obj_destroy (object_t * o); 40 | 41 | /* object hash functions */ 42 | uint32_t obj_hash (object_t * o); 43 | uint32_t hash (void *buf, size_t buflen); 44 | 45 | #define STRINGP(o) (o->type == STRING) 46 | #define SYMBOLP(o) (o->type == SYMBOL) 47 | #define CONSP(o) (o->type == CONS) 48 | 49 | #define UPREF(o) ((o)->refs++, o) 50 | 51 | /* Used for debugging: print string followed by object. */ 52 | #define DB_OP(str, o) printf(str); obj_print(o,1); 53 | 54 | #endif /* OBJECT_H */ 55 | -------------------------------------------------------------------------------- /lib/symtab.h: -------------------------------------------------------------------------------- 1 | /* symtab.h - functions related to symbols and the symbol table */ 2 | #ifndef SYMTAB_H 3 | #define SYMTAB_H 4 | 5 | #include "object.h" 6 | 7 | typedef struct symbol 8 | { 9 | char *name; 10 | char props; 11 | object_t **vals; 12 | object_t **stack; 13 | unsigned int cnt; 14 | } symbol_t; 15 | 16 | /* Must be called before any other symbtab functions are called. */ 17 | void symtab_init (); 18 | 19 | /* Symbol creation */ 20 | symbol_t *symbol_create (); 21 | object_t *c_sym (char *name); /* Interned symbol. */ 22 | object_t *c_usym (char *name); /* Uinterned symbol. */ 23 | void intern (object_t * sym); 24 | 25 | /* Dynamic scoping */ 26 | void sympop (object_t * so); 27 | void sympush (object_t * so, object_t * o); 28 | 29 | /* Useful macros for accessing the symbol's fields */ 30 | #define SYMNAME(so) (((symbol_t *) OVAL(so))->name) 31 | #define GET(so) (*((symbol_t *) OVAL(so))->vals) 32 | #define SET(so, o) (obj_destroy (GET (so)), (void) UPREF (o), \ 33 | *((symbol_t *) OVAL(so))->vals = o) 34 | #define SSET(so, o) (obj_destroy (GET (so)), *((symbol_t *) OVAL(so))->vals = o) 35 | 36 | /* Constants */ 37 | extern object_t *NIL; 38 | extern object_t *T; 39 | 40 | /* symbol properties */ 41 | #define SYM_CONSTANT 1 42 | #define SYM_INTERNED 2 43 | 44 | #define SYMPROPS(o) (((symbol_t *) OVAL(o))->props) 45 | #define CONSTANTP(o) (SYMPROPS(o) & SYM_CONSTANT) 46 | #define INTERNP(o) (SYMPROPS(o) & SYM_INTERNED) 47 | 48 | uint32_t symbol_hash (object_t * o); 49 | 50 | #endif /* SYMTAB_H */ 51 | -------------------------------------------------------------------------------- /lib/str.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "object.h" 4 | #include "common.h" 5 | #include "mem.h" 6 | #include "str.h" 7 | 8 | static mmanager_t *mm; 9 | 10 | static void str_clear (void *s) 11 | { 12 | str_t *str = (str_t *) s; 13 | str->raw = NULL; 14 | str->print = NULL; 15 | str->len = 0; 16 | } 17 | 18 | void str_init () 19 | { 20 | mm = mm_create (sizeof (str_t), &str_clear); 21 | } 22 | 23 | str_t *str_create () 24 | { 25 | return (str_t *) mm_alloc (mm); 26 | } 27 | 28 | void str_destroy (str_t * str) 29 | { 30 | xfree (str->raw); 31 | if (str->print != NULL) 32 | xfree (str->print); 33 | mm_free (mm, (void *) str); 34 | } 35 | 36 | void str_genp (object_t * o) 37 | { 38 | str_t *str = (str_t *) OVAL (o); 39 | if (str->print == NULL) 40 | str->print = unprocess_str (str->raw); 41 | } 42 | 43 | object_t *str_cat (object_t * ao, object_t * bo) 44 | { 45 | str_t *a = (str_t *) OVAL (ao); 46 | str_t *b = (str_t *) OVAL (bo); 47 | size_t nlen = a->len + b->len; 48 | char *nraw = xmalloc (nlen + 1); 49 | memcpy (nraw, a->raw, a->len); 50 | memcpy (nraw + a->len, b->raw, b->len); 51 | nraw[nlen] = '\0'; 52 | return c_str (nraw, nlen); 53 | } 54 | 55 | object_t *c_str (char *str, size_t len) 56 | { 57 | object_t *o = obj_create (STRING); 58 | OSTR (o) = str; 59 | OSTRLEN (o) = len; 60 | return o; 61 | } 62 | 63 | object_t *c_strs (char *str) 64 | { 65 | return c_str (str, strlen (str)); 66 | } 67 | 68 | uint32_t str_hash (object_t * o) 69 | { 70 | return hash (OSTR (o), OSTRLEN (o)); 71 | } 72 | -------------------------------------------------------------------------------- /lib/reader.h: -------------------------------------------------------------------------------- 1 | #ifndef READER_H 2 | #define READER_H 3 | 4 | #include 5 | #include "object.h" 6 | 7 | extern char *wisproot; 8 | 9 | /* stack-dependant reader state */ 10 | typedef struct reader_state 11 | { 12 | object_t *head; 13 | object_t *tail; 14 | int quote_mode, dotpair_mode, vector_mode; 15 | } rstate_t; 16 | 17 | /* the reader object */ 18 | typedef struct reader 19 | { 20 | /* source */ 21 | FILE *fid; 22 | char *str; 23 | 24 | /* meta */ 25 | char *name; 26 | int interactive; 27 | char *prompt; 28 | 29 | /** reader state **/ 30 | unsigned int linecnt; 31 | char *strp; 32 | 33 | /* atom read buffer */ 34 | char *buf, *bufp; 35 | size_t buflen; 36 | 37 | /* read buffer */ 38 | int *readbuf, *readbufp; 39 | size_t readbuflen; 40 | 41 | /* indicators */ 42 | int eof, error, shebang, done; 43 | 44 | /* state stack */ 45 | size_t ssize; 46 | rstate_t *base; 47 | rstate_t *state; 48 | } reader_t; 49 | 50 | /* Create a new reader object, passing either a string or file handle 51 | * for parsing. */ 52 | reader_t *reader_create (FILE * fid, char *str, char *name, int interactive); 53 | void reader_destroy (reader_t * r); 54 | 55 | /* Read a single sexp from the reader. */ 56 | object_t *read_sexp (reader_t * r); 57 | 58 | /* Use the core functions above to eval each sexp in a file. */ 59 | int load_file (FILE * fid, char *filename, int interactive); 60 | 61 | /* Convenience function for calling load_file() on stdin. */ 62 | void repl (); 63 | 64 | /* Load a library file from the Wisp root */ 65 | int require (char *libname); 66 | 67 | extern char *prompt; 68 | 69 | #endif /* READER_H */ 70 | -------------------------------------------------------------------------------- /core.wisp: -------------------------------------------------------------------------------- 1 | ;;; Core definitions for Wisp 2 | 3 | ;; Set up require, so we can start pulling external libraries 4 | 5 | (defmacro push (x place) 6 | "Push x onto list stored at place." 7 | (list 'set (list 'quote place) (list 'cons x place))) 8 | 9 | (defun equal (a b) 10 | "Return t if both arguments have similar structure and contents." 11 | (or (eql a b) 12 | (and (listp a) 13 | (listp b) 14 | (equal (car a) (car b)) 15 | (equal (cdr a) (cdr b))))) 16 | 17 | (defun member (el lst) 18 | "Return non-nil if the element is in the list." 19 | (if (nullp lst) 20 | nil 21 | (if (equal el (car lst)) 22 | lst 23 | (member el (cdr lst))))) 24 | 25 | (defun concat (str &rest strs) 26 | "Concatenate any number of strings." 27 | (if (nullp strs) 28 | str 29 | (concat2 str (apply concat strs)))) 30 | 31 | (defun provide (lib) 32 | "Set library as already loaded." 33 | (push lib provide-list)) 34 | 35 | (defun require (lib) 36 | "Bring library functions into current environment." 37 | (if (member lib provide-list) t 38 | (load (concat wisproot "/wisplib/" (symbol-name lib) ".wisp")))) 39 | 40 | ;; Load up other default libraries 41 | (require 'list) 42 | (require 'math) 43 | (require 'vector) 44 | (require 'set) 45 | 46 | (defmacro setq (var val) 47 | "Automatically quote the first argument for set." 48 | (list 'set (list 'quote var) val)) 49 | 50 | (defun make-symbol (str) 51 | "Make symbol from string." 52 | (if (not (stringp str)) 53 | (throw 'wrong-type-argument str) 54 | (read-string str))) 55 | 56 | (defun doc-string (f) 57 | "Return documentation string for object." 58 | (if (symbolp f) 59 | (setq f (value f))) 60 | (if (listp f) 61 | (if (stringp (third f)) 62 | (third f)) 63 | (cdoc-string f))) 64 | -------------------------------------------------------------------------------- /wisp.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "lib/wisp.h" 6 | 7 | char *version = "alpha"; 8 | 9 | /* options */ 10 | char *progname; 11 | int force_interaction = 0; 12 | int print_help = 0; 13 | 14 | void print_usage (int ret) 15 | { 16 | printf ("Usage: %s [switches] programfile [arguments]\n", progname); 17 | printf ("\t-i Force interaction mode\n"); 18 | printf ("\t-v Print version information\n"); 19 | printf ("\t-h Print this usage text\n"); 20 | exit (ret); 21 | } 22 | 23 | void print_version () 24 | { 25 | printf ("wisp, version %s\n", version); 26 | } 27 | 28 | int main (int argc, char **argv) 29 | { 30 | progname = argv[0]; 31 | wisp_init (); 32 | 33 | /* parse arguments */ 34 | int c; 35 | while ((c = getopt (argc, argv, "+ihv")) != -1) 36 | switch (c) 37 | { 38 | case 'i': 39 | force_interaction = 1; 40 | break; 41 | case 'v': 42 | print_version (); 43 | break; 44 | case 'h': 45 | print_help = 1; 46 | break; 47 | case '?': 48 | print_usage (EXIT_FAILURE); 49 | break; 50 | } 51 | if (print_help) 52 | print_usage (EXIT_SUCCESS); 53 | 54 | if (argc - optind < 1) 55 | { 56 | /* Run interaction. */ 57 | repl (); 58 | } 59 | else 60 | { 61 | /* Run script */ 62 | char *file = argv[optind]; 63 | FILE *fid = fopen (file, "r"); 64 | if (fid == NULL) 65 | { 66 | fprintf (stderr, "error: could not load %s: %s\n", 67 | file, strerror (errno)); 68 | exit (EXIT_FAILURE); 69 | } 70 | /* expose argv to wisp program */ 71 | object_t *args = NIL; 72 | while (argc > optind) 73 | { 74 | args = c_cons (c_strs (xstrdup (argv[argc - 1])), args); 75 | argc--; 76 | } 77 | SET (c_sym ("ARGS"), args); 78 | load_file (fid, file, 0); 79 | fclose (fid); 80 | } 81 | return EXIT_SUCCESS; 82 | } 83 | -------------------------------------------------------------------------------- /lib/eval.h: -------------------------------------------------------------------------------- 1 | /* eval.h - list evaluation/execution functions */ 2 | #ifndef EVAL_H 3 | #define EVAL_H 4 | 5 | #include "cons.h" 6 | #include "object.h" 7 | #include "common.h" 8 | #include "str.h" 9 | 10 | /* Initializes everything. */ 11 | void wisp_init (); 12 | 13 | /* Must be called before calling any other functions. */ 14 | void eval_init (); 15 | 16 | object_t *eval (object_t * o); 17 | object_t *top_eval (object_t * o); 18 | object_t *eval_body (object_t * body); 19 | object_t *assign_args (object_t * vars, object_t * vals); 20 | void unassign_args (object_t * vars); 21 | object_t *apply (object_t * f, object_t * rawargs); 22 | 23 | extern unsigned int stack_depth, max_stack_depth; 24 | extern int interactive_mode; 25 | 26 | /* Frequently used symbols */ 27 | extern object_t *lambda, *macro, *rest, *optional, *quote; 28 | extern object_t *doc_string; 29 | 30 | #define FUNCP(o) \ 31 | ((o->type == CONS && CAR(o)->type == SYMBOL \ 32 | && ((CAR(o) == lambda) || (CAR(o) == macro))) \ 33 | || (o->type == CFUNC) || (o->type == SPECIAL)) 34 | 35 | /* Error handling */ 36 | extern object_t *err_symbol, *err_thrown, *err_attach; 37 | extern object_t *void_function, *wrong_number_of_arguments, *wrong_type, 38 | *improper_list, *improper_list_ending, *err_interrupt; 39 | 40 | #define THROW(to, ao) {err_thrown = to; err_attach = ao; return err_symbol;} 41 | #define CHECK(o) if ((o) == err_symbol) return err_symbol; 42 | 43 | #define REQ(lst, n, so) if (req_length (lst, so, n) == err_symbol) \ 44 | return err_symbol; 45 | #define REQM(lst, n, so) if (reqm_length (lst, so, n) == err_symbol) \ 46 | return err_symbol; 47 | #define REQX(lst, n, so) if (reqx_length (lst, so, n) == err_symbol) \ 48 | return err_symbol; 49 | #define REQPROP(lst) if (properlistp(lst) == NIL) \ 50 | THROW (improper_list, lst); 51 | #define DOC(str) if (lst == doc_string) return c_strs (xstrdup (str)); 52 | 53 | #endif /* EVAL_H */ 54 | -------------------------------------------------------------------------------- /SConstruct: -------------------------------------------------------------------------------- 1 | # SConstruct - Wisp build system 2 | # 3 | # Documentation and test suite will be built automatically. To run the 4 | # test suite, use the "check" target. 5 | # 6 | # scons check 7 | # 8 | import os 9 | 10 | # Documentation building 11 | docbld = Builder(action = 'asciidoc -o $TARGET $SOURCE') 12 | 13 | # Create new environement 14 | normal = Environment( 15 | CC = 'gcc', 16 | CFLAGS = ['-W', '-Wall', '-g', '-O2'], 17 | LIBPATH = ['/usr/lib', '/usr/local/lib'], 18 | CPPPATH = ['/usr/include', '/usr/local/include'], 19 | BUILDERS = {'AsciiDoc' : docbld}) 20 | 21 | # Configure the environment 22 | conf = Configure(normal) 23 | print 'Configuring...' 24 | if not conf.CheckFunc('printf'): 25 | print 'error: couldn\'t find a working C compiler' 26 | Exit(1) 27 | if not conf.CheckLibWithHeader('gmp', 'gmp.h', 'c'): 28 | print 'error: could not find libgmp and/or gmp.h' 29 | print ' GNU Multiple Precision (GMP) library with headers required' 30 | Exit(1) 31 | if not os.path.exists('/usr/bin/asciidoc'): 32 | print 'AsciiDoc not found - docs will not be built' 33 | conf.env['noasciidoc'] = True 34 | if 'CC' in os.environ: 35 | conf.env.Replace(CC = os.environ['CC']) 36 | conf.env.Replace(CFLAGS = '') 37 | print(">> Using compiler " + os.environ['CC']) 38 | if 'CFLAGS' in os.environ: 39 | conf.env.Append(CFLAGS = os.environ['CFLAGS']) 40 | print(">> Appending custom build flags : " + os.environ['CFLAGS']) 41 | if 'LDFLAGS' in os.environ: 42 | conf.env.Append(LINKFLAGS = os.environ['LDFLAGS']) 43 | print(">> Appending custom link flags : " + os.environ['LDFLAGS']) 44 | normal = conf.Finish() 45 | Export('normal') 46 | 47 | # Include subdirectories 48 | SConscript('lib/SConscript') 49 | SConscript('test/SConscript') 50 | SConscript('doc/SConscript') 51 | 52 | # Main program 53 | normal.Program(target = 'wisp', 54 | LIBS = [File('lib/libwisp.a'), 'gmp'], 55 | LIBPATH = normal['LIBPATH'] + ['lib'], 56 | source = 'wisp.c') 57 | -------------------------------------------------------------------------------- /lib/symtab.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "common.h" 4 | #include "symtab.h" 5 | #include "object.h" 6 | #include "hashtab.h" 7 | 8 | static hashtab_t *symbol_table; 9 | 10 | object_t *NIL, *T; 11 | 12 | void symtab_init () 13 | { 14 | symbol_table = ht_init (2048, NULL); 15 | 16 | /* Set up t and nil constants. The SET macro won't work until NIL is set. */ 17 | NIL = c_sym ("nil"); 18 | *((symbol_t *) OVAL (NIL))->vals = NIL; 19 | SYMPROPS (NIL) |= SYM_CONSTANT; 20 | T = c_sym ("t"); 21 | SYMPROPS (T) |= SYM_CONSTANT; 22 | SET (T, T); 23 | } 24 | 25 | symbol_t *symbol_create () 26 | { 27 | symbol_t *s = xmalloc (sizeof (symbol_t)); 28 | s->props = 0; 29 | s->cnt = 8; 30 | s->vals = s->stack = xmalloc (sizeof (object_t *) * s->cnt); 31 | return s; 32 | } 33 | 34 | void sympush (object_t * so, object_t * o) 35 | { 36 | symbol_t *s = (symbol_t *) OVAL (so); 37 | s->vals++; 38 | if (s->vals == s->cnt + s->stack) 39 | { 40 | size_t n = s->vals - s->stack; 41 | s->cnt *= 2; 42 | s->stack = xrealloc (s->stack, s->cnt * sizeof (object_t *)); 43 | s->vals = s->stack + n; 44 | } 45 | *s->vals = o; 46 | UPREF (o); 47 | } 48 | 49 | void sympop (object_t * so) 50 | { 51 | obj_destroy (GET (so)); 52 | symbol_t *s = (symbol_t *) OVAL (so); 53 | s->vals--; 54 | } 55 | 56 | object_t *c_usym (char *name) 57 | { 58 | object_t *o; 59 | char *newname = xstrdup (name); 60 | o = obj_create (SYMBOL); 61 | SYMNAME (o) = newname; 62 | *((symbol_t *) OVAL (o))->vals = NIL; 63 | if (name[0] == ':') 64 | SET (o, o); 65 | return o; 66 | } 67 | 68 | void intern (object_t * sym) 69 | { 70 | ht_insert (symbol_table, SYMNAME (sym), strlen (SYMNAME (sym)), sym, 71 | sizeof (object_t *)); 72 | SYMPROPS (sym) |= SYM_INTERNED; 73 | } 74 | 75 | object_t *c_sym (char *name) 76 | { 77 | object_t *o = (object_t *) ht_search (symbol_table, name, strlen (name)); 78 | if (o == NULL) 79 | { 80 | o = c_usym (name); 81 | intern (o); 82 | } 83 | return o; 84 | } 85 | 86 | uint32_t symbol_hash (object_t * o) 87 | { 88 | return hash (SYMNAME (o), strlen (SYMNAME (o))); 89 | } 90 | -------------------------------------------------------------------------------- /wisplib/list.wisp: -------------------------------------------------------------------------------- 1 | ;;; List utility functions 2 | 3 | ;; Two letters 4 | 5 | (defun cadr (lst) 6 | (car (cdr lst))) 7 | 8 | (defun cdar (lst) 9 | (cdr (car lst))) 10 | 11 | (defun caar (lst) 12 | (car (car lst))) 13 | 14 | (defun cddr (lst) 15 | (cdr (cdr lst))) 16 | 17 | ;; Three letters 18 | 19 | (defun caaar (lst) 20 | (car (car (car lst)))) 21 | 22 | (defun caadr (lst) 23 | (car (car (cdr lst)))) 24 | 25 | (defun cadar (lst) 26 | (car (cdr (car lst)))) 27 | 28 | (defun caddr (lst) 29 | (car (cdr (cdr lst)))) 30 | 31 | (defun cdaar (lst) 32 | (cdr (car (car lst)))) 33 | 34 | (defun cdadr (lst) 35 | (cdr (car (cdr lst)))) 36 | 37 | (defun cddar (lst) 38 | (cdr (cdr (car lst)))) 39 | 40 | (defun cdddr (lst) 41 | (cdr (cdr (cdr lst)))) 42 | 43 | ;; Up to ten 44 | 45 | (defun first (lst) 46 | (car lst)) 47 | 48 | (defun second (lst) 49 | (first (cdr lst))) 50 | 51 | (defun third (lst) 52 | (second (cdr lst))) 53 | 54 | (defun fourth (lst) 55 | (third (cdr lst))) 56 | 57 | (defun fifth (lst) 58 | (fourth (cdr lst))) 59 | 60 | (defun sixth (lst) 61 | (fifth (cdr lst))) 62 | 63 | (defun seventh (lst) 64 | (sixth (cdr lst))) 65 | 66 | (defun eighth (lst) 67 | (seventh (cdr lst))) 68 | 69 | (defun ninth (lst) 70 | (eighth (cdr lst))) 71 | 72 | (defun tenth (lst) 73 | (ninth (cdr lst))) 74 | 75 | ;; General functions 76 | 77 | (defun nth (n lst) 78 | "Return nth element of list." 79 | (if (= n 0) 80 | (car lst) 81 | (nth (- n 1) (cdr lst)))) 82 | 83 | (defun length (lst) 84 | "Return length of list." 85 | (if (nullp lst) 86 | 0 87 | (1+ (length (cdr lst))))) 88 | 89 | (defun reduce (f lst) 90 | "Reduce two-argument function across list." 91 | (if (= (length lst) 1) 92 | (f (car lst)) 93 | (f (car lst) (reduce f (cdr lst))))) 94 | 95 | (defun append (lst &rest lsts) 96 | "Concatenate any number of lists." 97 | (cond 98 | ((nullp lsts) lst) 99 | ((= 1 (length lst)) (cons (car lst) (apply append lsts))) 100 | (t (cons (car lst) 101 | (append (cdr lst) (apply append lsts)))))) 102 | 103 | (provide 'list) 104 | -------------------------------------------------------------------------------- /test/wisp_tests.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include "../lib/wisp.h" 7 | 8 | /* Error testing */ 9 | void assert (int b, char *msg); 10 | int err_cnt = 0, test_cnt = 0; 11 | 12 | /* Tests */ 13 | void symbol_tests (); 14 | void string_tests (); 15 | void wisp_tests (); 16 | 17 | int main () 18 | { 19 | wisp_init (); 20 | 21 | printf ("Running symbol tests ...\n"); 22 | symbol_tests (); 23 | printf ("Running string tests ...\n"); 24 | string_tests (); 25 | printf ("Running Wisp code tests ...\n"); 26 | wisp_tests (); 27 | 28 | /* Count up errors and exit */ 29 | if (err_cnt == 0) 30 | { 31 | printf ("All %d tests passed.\n", test_cnt); 32 | exit (EXIT_SUCCESS); 33 | } 34 | else 35 | { 36 | printf ("%d tests failed.\n", err_cnt); 37 | exit (EXIT_FAILURE); 38 | } 39 | } 40 | 41 | void assert (int b, char *msg) 42 | { 43 | test_cnt++; 44 | if (!b) 45 | { 46 | fprintf (stderr, "failed: %s\n", msg); 47 | err_cnt++; 48 | } 49 | } 50 | 51 | void string_tests () 52 | { 53 | assert (strcmp (process_str ("\"Hello\\\" there!\""), "Hello\" there!") == 54 | 0, "process_str()"); 55 | assert (strcmp (unprocess_str ("Hello\" there!"), "\"Hello\\\" there!\"") == 56 | 0, "unprocess_str()"); 57 | } 58 | 59 | void symbol_tests () 60 | { 61 | assert (c_sym ("symbol") == c_sym ("symbol"), "symbol interning"); 62 | assert (strcmp (SYMNAME (c_sym ("str")), "str") == 0, "SYMNAME test"); 63 | 64 | /* dynamic scoping */ 65 | object_t *so = c_sym ("s"); 66 | object_t *a = c_sym ("a"); 67 | object_t *b = c_sym ("b"); 68 | object_t *c = c_sym ("c"); 69 | SET (so, a); 70 | sympush (so, b); 71 | sympush (so, c); 72 | assert (GET (so) == c, "symbol push/pop 1"); 73 | sympop (so); 74 | assert (GET (so) == b, "symbol push/pop 2"); 75 | sympop (so); 76 | assert (GET (so) == a, "symbol push/pop 3"); 77 | } 78 | 79 | int run_wisp_test (char *file) 80 | { 81 | /* fork() so that failures don't kill this process */ 82 | if (fork () == 0) 83 | { 84 | execl ("wisp", "wisp", file, NULL); 85 | fprintf (stderr, "%s\n", strerror (errno)); 86 | exit (1); 87 | } 88 | int r; 89 | wait (&r); 90 | return r == 0; 91 | } 92 | 93 | void wisp_tests () 94 | { 95 | assert (run_wisp_test ("test/stress.wisp"), "Wisp stress test"); 96 | assert (run_wisp_test ("test/eq-test.wisp"), "Wisp equality"); 97 | } 98 | -------------------------------------------------------------------------------- /lib/common.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "common.h" 6 | 7 | void *xmalloc (size_t size) 8 | { 9 | void *p = malloc (size); 10 | if (p == NULL) 11 | { 12 | fprintf (stderr, "error: fatal: out of memory: %s\n", strerror (errno)); 13 | exit (EXIT_FAILURE); 14 | } 15 | return p; 16 | } 17 | 18 | void *xrealloc (void *p, size_t size) 19 | { 20 | void *np = realloc (p, size); 21 | if (np == NULL) 22 | { 23 | fprintf (stderr, "error: fatal: out of memory: %s\n", strerror (errno)); 24 | exit (EXIT_FAILURE); 25 | } 26 | return np; 27 | } 28 | 29 | void xfree (void *p) 30 | { 31 | free (p); 32 | } 33 | 34 | char *xstrdup (char *str) 35 | { 36 | char *newstr = xmalloc (strlen (str) + 1); 37 | strcpy (newstr, str); 38 | return newstr; 39 | } 40 | 41 | char *pathcat (char *prefix, char *path) 42 | { 43 | char *str = xmalloc (strlen (prefix) + strlen (path) + 2); 44 | strcpy (str, prefix); 45 | str[strlen (prefix)] = '/'; /* Extra / don't hurt. */ 46 | strcpy (str + strlen (prefix) + 1, path); 47 | return str; 48 | } 49 | 50 | char *process_str (char *rawstr) 51 | { 52 | char *str = xstrdup (rawstr + 1); /* trim leading quote */ 53 | 54 | /* Remove backquotes. */ 55 | char *eq; 56 | char *p = str; 57 | while ((eq = strchr (p, '\\')) != NULL) 58 | { 59 | /* replace \ with next character */ 60 | *eq = *(eq + 1); 61 | memmove (eq + 1, eq + 2, strlen (eq) + 1); 62 | p = eq + 1; 63 | } 64 | 65 | str[strlen (str) - 1] = '\0'; /* remove trailing quote */ 66 | 67 | return str; 68 | } 69 | 70 | char *unprocess_str (char *cleanstr) 71 | { 72 | /* Count the quotes and backquotes. */ 73 | char *p = cleanstr; 74 | int cnt = 0; 75 | while (*p != '\0') 76 | { 77 | if (*p == '\\' || *p == '"') 78 | cnt++; 79 | p++; 80 | } 81 | 82 | /* Two extra for quotes and one for each character that needs 83 | escaping. */ 84 | char *str = xmalloc (strlen (cleanstr) + cnt + 2 + 1); 85 | strcpy (str + 1, cleanstr); 86 | 87 | /* Place backquotes. */ 88 | char *c = str + 1; 89 | while (*c != '\0') 90 | { 91 | if (*c == '\\' || *c == '"') 92 | { 93 | memmove (c + 1, c, strlen (c) + 1); 94 | *c = '\\'; 95 | c++; 96 | } 97 | c++; 98 | } 99 | 100 | /* Surrounding quotes. */ 101 | str[0] = '"'; 102 | str[strlen (str) + 1] = '\0'; 103 | str[strlen (str)] = '"'; 104 | 105 | return str; 106 | } 107 | 108 | void error (char *str) 109 | { 110 | printf ("%s\n", str); 111 | } 112 | -------------------------------------------------------------------------------- /lib/detach.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include "object.h" 7 | #include "symtab.h" 8 | #include "eval.h" 9 | #include "reader.h" 10 | #include "detach.h" 11 | 12 | object_t *parent_detach; 13 | 14 | uint8_t detach_hash (object_t * o) 15 | { 16 | pid_t proc = OPROC (o); 17 | return hash (&proc, sizeof (pid_t)); 18 | } 19 | 20 | void detach_print (object_t * o) 21 | { 22 | pid_t proc = OPROC (o); 23 | printf ("", proc); 24 | } 25 | 26 | object_t *c_detach (object_t * o) 27 | { 28 | if (SYMBOLP (o)) 29 | o = GET (o); 30 | object_t *dob = obj_create (DETACH); 31 | detach_t *d = OVAL (dob); 32 | int pipea[2], pipeb[2]; 33 | if (pipe (pipea) != 0) 34 | THROW (c_sym ("detach-pipe-error"), c_strs (xstrdup (strerror (errno)))); 35 | if (pipe (pipeb) != 0) 36 | THROW (c_sym ("detach-pipe-error"), c_strs (xstrdup (strerror (errno)))); 37 | d->proc = fork (); 38 | if (d->proc == 0) 39 | { 40 | /* Child process */ 41 | 42 | /* Set up pipes */ 43 | d->in = pipeb[0]; 44 | d->out = pipea[1]; 45 | close (pipeb[1]); 46 | close (pipea[0]); 47 | 48 | /* Change stdin and stdout. */ 49 | fclose (stdin); 50 | int stdout_no = fileno (stdout); 51 | close (stdout_no); 52 | dup2 (d->out, stdout_no); 53 | d->read = reader_create (fdopen (d->in, "r"), NULL, "parent", 0); 54 | parent_detach = dob; 55 | 56 | /* Execute given function. */ 57 | object_t *f = c_cons (o, NIL); 58 | eval (f); 59 | exit (0); 60 | THROW (c_sym ("exit-failed"), dob); 61 | } 62 | /* Parent process */ 63 | d->in = pipea[0]; 64 | d->out = pipeb[1]; 65 | close (pipea[1]); 66 | close (pipeb[0]); 67 | d->read = reader_create (fdopen (d->in, "r"), NULL, "detach", 0); 68 | return dob; 69 | } 70 | 71 | detach_t *detach_create () 72 | { 73 | return (detach_t *) xmalloc (sizeof (detach_t)); 74 | } 75 | 76 | void detach_destroy (object_t * o) 77 | { 78 | detach_t *d = OVAL (o); 79 | reader_destroy (d->read); 80 | close (d->in); 81 | close (d->out); 82 | } 83 | 84 | object_t *lisp_detach (object_t * lst) 85 | { 86 | DOC ("Create process detachment."); 87 | REQ (lst, 1, c_sym ("detach")); 88 | return c_detach (CAR (lst)); 89 | } 90 | 91 | object_t *lisp_receive (object_t * lst) 92 | { 93 | DOC ("Get an object from the detached process."); 94 | REQ (lst, 1, c_sym ("receive")); 95 | object_t *d = CAR (lst); 96 | if (!DETACHP (d)) 97 | THROW (wrong_type, UPREF (d)); 98 | reader_t *r = OREAD (d); 99 | return read_sexp (r); 100 | } 101 | 102 | object_t *lisp_send (object_t * lst) 103 | { 104 | DOC ("Send an object to the parent process."); 105 | REQ (lst, 1, c_sym ("send")); 106 | object_t *o = CAR (lst); 107 | if (parent_detach == NULL || parent_detach == NIL) 108 | THROW (c_sym ("send-from-non-detachment"), UPREF (o)); 109 | obj_print (o, 1); 110 | return T; 111 | } 112 | -------------------------------------------------------------------------------- /lib/cons.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "mem.h" 3 | #include "object.h" 4 | #include "symtab.h" 5 | #include "cons.h" 6 | #include "eval.h" 7 | 8 | static mmanager_t *mm; 9 | 10 | static void cons_clear (void *o) 11 | { 12 | cons_t *c = (cons_t *) o; 13 | c->car = NIL; 14 | c->cdr = NIL; 15 | } 16 | 17 | void cons_init () 18 | { 19 | mm = mm_create (sizeof (cons_t), &cons_clear); 20 | } 21 | 22 | cons_t *cons_create () 23 | { 24 | return (cons_t *) mm_alloc (mm); 25 | } 26 | 27 | void cons_destroy (cons_t * o) 28 | { 29 | mm_free (mm, (void *) o); 30 | } 31 | 32 | object_t *req_length (object_t * lst, object_t * thr, int n) 33 | { 34 | /* TODO detect loops? */ 35 | int cnt = 0; 36 | object_t *p = lst; 37 | while (p != NIL) 38 | { 39 | cnt++; 40 | p = CDR (p); 41 | if (!LISTP (p)) 42 | { 43 | obj_destroy (thr); 44 | THROW (improper_list, lst); 45 | } 46 | if (cnt > n) 47 | THROW (wrong_number_of_arguments, thr); 48 | } 49 | if (cnt != n) 50 | THROW (wrong_number_of_arguments, thr); 51 | return T; 52 | } 53 | 54 | object_t *reqm_length (object_t * lst, object_t * thr, int n) 55 | { 56 | /* TODO detect loops? */ 57 | int cnt = 0; 58 | object_t *p = lst; 59 | while (p != NIL) 60 | { 61 | cnt++; 62 | p = CDR (p); 63 | if (!LISTP (p)) 64 | { 65 | obj_destroy (thr); 66 | THROW (improper_list, lst); 67 | } 68 | if (cnt >= n) 69 | return T; 70 | } 71 | if (cnt < n) 72 | THROW (wrong_number_of_arguments, thr); 73 | return T; 74 | } 75 | 76 | object_t *reqx_length (object_t * lst, object_t * thr, int n) 77 | { 78 | /* TODO detect loops? */ 79 | int cnt = 0; 80 | object_t *p = lst; 81 | while (p != NIL) 82 | { 83 | cnt++; 84 | p = CDR (p); 85 | if (!LISTP (p)) 86 | { 87 | obj_destroy (thr); 88 | THROW (improper_list, lst); 89 | } 90 | if (cnt > n) 91 | THROW (wrong_number_of_arguments, thr); 92 | } 93 | return T; 94 | } 95 | 96 | /* Verifies that list has form of a function. */ 97 | int is_func_form (object_t * lst) 98 | { 99 | if (!LISTP (CAR (lst))) 100 | return 0; 101 | return is_var_list (CAR (lst)); 102 | } 103 | 104 | /* Verifies that list is made only of symbols. */ 105 | int is_var_list (object_t * lst) 106 | { 107 | int rest_cnt = -1; 108 | while (lst != NIL) 109 | { 110 | object_t *car = CAR (lst); 111 | /* &rest must be the second to last item */ 112 | if (rest_cnt >= 0) 113 | { 114 | rest_cnt--; 115 | if (rest_cnt < 0) 116 | return 0; 117 | if (car == rest) 118 | return 0; 119 | } 120 | if (!SYMBOLP (car)) 121 | return 0; 122 | if (car == rest) 123 | rest_cnt = 1; 124 | lst = CDR (lst); 125 | } 126 | if (rest_cnt == 1) 127 | return 0; 128 | return 1; 129 | } 130 | 131 | /* Determine if list is proper (ends with NIL) */ 132 | object_t *properlistp (object_t * lst) 133 | { 134 | if (lst == NIL) 135 | return T; 136 | if (!CONSP (lst)) 137 | return NIL; 138 | return properlistp (CDR (lst)); 139 | } 140 | 141 | uint32_t cons_hash (object_t * o) 142 | { 143 | return obj_hash (CAR (o)) ^ obj_hash (CDR (o)); 144 | } 145 | -------------------------------------------------------------------------------- /lib/hashtab.h: -------------------------------------------------------------------------------- 1 | /* hashtab.h - generic hashtable implementation for use anywhere */ 2 | #ifndef HASHTAB_H 3 | #define HASHTAB_H 4 | 5 | #include 6 | 7 | typedef struct hashtab_node_t 8 | { 9 | void *key; /* key for the node */ 10 | size_t keylen; /* length of the key */ 11 | void *value; /* value for this node */ 12 | size_t vallen; /* length of the value */ 13 | 14 | struct hashtab_node_t *next; /* next node (open hashtable) */ 15 | } hashtab_node_t; 16 | 17 | typedef struct hashtab_t 18 | { 19 | hashtab_node_t **arr; 20 | size_t size; /* size of the hash */ 21 | int count; /* number if items in this table */ 22 | int (*hash_func) (void *, size_t, size_t); /* hash function */ 23 | } hashtab_t; 24 | 25 | /* Iterator type for iterating through the hashtable. */ 26 | typedef struct hashtab_iter_t 27 | { 28 | /* key and value of current item */ 29 | void *key; 30 | void *value; 31 | size_t keylen; 32 | size_t vallen; 33 | 34 | /* bookkeeping data */ 35 | struct hashtab_internal_t 36 | { 37 | hashtab_t *hashtable; 38 | hashtab_node_t *node; 39 | int index; 40 | } internal; 41 | 42 | } hashtab_iter_t; 43 | 44 | /* Initialize a new hashtable (set bookingkeeping data) and return a 45 | * pointer to the hashtable. A hash function may be provided. If no 46 | * function pointer is given (a NULL pointer), then the built in hash 47 | * function is used. A NULL pointer returned if the creation of the 48 | * hashtable failed due to a failed malloc(). */ 49 | hashtab_t *ht_init (size_t size, 50 | int (*hash_func) 51 | (void *key, size_t keylen, size_t ht_size)); 52 | 53 | /* Fetch a value from table matching the key. Returns a pointer to 54 | * the value matching the given key. */ 55 | void *ht_search (hashtab_t * hashtable, void *key, size_t keylen); 56 | 57 | /* Put a value into the table with the given key. Returns NULL if 58 | * malloc() fails to allocate memory for the new node. */ 59 | void *ht_insert (hashtab_t * hashtable, 60 | void *key, size_t keylen, void *value, size_t vallen); 61 | 62 | /* Delete the given key and value pair from the hashtable. If the key 63 | * does not exist, no error is given. */ 64 | void ht_remove (hashtab_t * hashtable, void *key, size_t keylen); 65 | 66 | /* Change the size of the hashtable. It will allocate a new hashtable 67 | * and move all keys and values over. The pointer to the new hashtable 68 | * is returned. Will return NULL if the new hashtable fails to be 69 | * allocated. If this happens, the old hashtable will not be altered 70 | * in any way. The old hashtable is destroyed upon a successful 71 | * grow. */ 72 | hashtab_t *ht_grow (hashtab_t * hashtable, size_t new_size); 73 | 74 | /* Free all resources used by the hashtable. */ 75 | void ht_destroy (hashtab_t * hashtable); 76 | 77 | /* Initialize the given iterator. It will point to the first element 78 | * in the hashtable. */ 79 | void ht_iter_init (hashtab_t * hashtable, hashtab_iter_t * ii); 80 | 81 | /* Increment the iterator to the next element. The iterator key and 82 | * value will point to NULL values when the iterator has reached the 83 | * end of the hashtable. */ 84 | void ht_iter_inc (hashtab_iter_t * ii); 85 | 86 | /* Default hashtable hash function. */ 87 | int ht_hash (void *key, size_t key_size, size_t hashtab_size); 88 | 89 | #endif 90 | -------------------------------------------------------------------------------- /lib/vector.c: -------------------------------------------------------------------------------- 1 | #include "vector.h" 2 | #include "object.h" 3 | #include "common.h" 4 | #include "symtab.h" 5 | #include "cons.h" 6 | #include "number.h" 7 | #include "mem.h" 8 | #include "eval.h" 9 | 10 | static mmanager_t *mm; 11 | static object_t *out_of_bounds; 12 | 13 | static void vector_clear (void *o) 14 | { 15 | vector_t *v = (vector_t *) o; 16 | v->v = NULL; 17 | v->len = 0; 18 | } 19 | 20 | void vector_init () 21 | { 22 | mm = mm_create (sizeof (vector_t), &vector_clear); 23 | out_of_bounds = c_sym ("index-out-of-bounds"); 24 | } 25 | 26 | vector_t *vector_create () 27 | { 28 | return (vector_t *) mm_alloc (mm); 29 | } 30 | 31 | void vector_destroy (vector_t * v) 32 | { 33 | size_t i; 34 | for (i = 0; i < v->len; i++) 35 | obj_destroy (v->v[i]); 36 | xfree (v->v); 37 | mm_free (mm, (void *) v); 38 | } 39 | 40 | object_t *c_vec (size_t len, object_t * init) 41 | { 42 | object_t *o = obj_create (VECTOR); 43 | vector_t *v = OVAL (o); 44 | v->len = len; 45 | if (len == 0) 46 | len = 1; 47 | v->v = xmalloc (sizeof (object_t **) * len); 48 | size_t i; 49 | for (i = 0; i < v->len; i++) 50 | v->v[i] = UPREF (init); 51 | return o; 52 | } 53 | 54 | object_t *list2vector (object_t * lst) 55 | { 56 | int cnt = 0; 57 | object_t *p = lst; 58 | while (p != NIL) 59 | { 60 | cnt++; 61 | p = CDR (p); 62 | } 63 | object_t *v = c_vec (cnt, NIL); 64 | p = lst; 65 | size_t i = 0; 66 | while (p != NIL) 67 | { 68 | vset (v, i, UPREF (CAR (p))); 69 | i++; 70 | p = CDR (p); 71 | } 72 | return v; 73 | } 74 | 75 | void vset (object_t * vo, size_t i, object_t * val) 76 | { 77 | vector_t *v = OVAL (vo); 78 | object_t *o = v->v[i]; 79 | v->v[i] = val; 80 | obj_destroy (o); 81 | } 82 | 83 | object_t *vset_check (object_t * vo, object_t * io, object_t * val) 84 | { 85 | int i = into2int (io); 86 | vector_t *v = OVAL (vo); 87 | if (i < 0 || i >= (int) v->len) 88 | THROW (out_of_bounds, UPREF (io)); 89 | vset (vo, i, UPREF (val)); 90 | return UPREF (val); 91 | } 92 | 93 | object_t *vget (object_t * vo, size_t i) 94 | { 95 | vector_t *v = OVAL (vo); 96 | return v->v[i]; 97 | } 98 | 99 | object_t *vget_check (object_t * vo, object_t * io) 100 | { 101 | int i = into2int (io); 102 | vector_t *v = OVAL (vo); 103 | if (i < 0 || i >= (int) v->len) 104 | THROW (out_of_bounds, UPREF (io)); 105 | return UPREF (vget (vo, i)); 106 | } 107 | 108 | void vec_print (object_t * vo) 109 | { 110 | vector_t *v = OVAL (vo); 111 | if (v->len == 0) 112 | { 113 | printf ("[]"); 114 | return; 115 | } 116 | printf ("["); 117 | size_t i; 118 | for (i = 0; i < v->len - 1; i++) 119 | { 120 | obj_print (v->v[i], 0); 121 | printf (" "); 122 | } 123 | obj_print (v->v[v->len - 1], 0); 124 | printf ("]"); 125 | } 126 | 127 | object_t *vector_concat (object_t * a, object_t * b) 128 | { 129 | size_t al = VLENGTH (a), bl = VLENGTH (b); 130 | object_t *c = c_vec (al + bl, NIL); 131 | size_t i; 132 | for (i = 0; i < al; i++) 133 | vset (c, i, UPREF (vget (a, i))); 134 | for (i = 0; i < bl; i++) 135 | vset (c, i + al, UPREF (vget (b, i))); 136 | return c; 137 | } 138 | 139 | object_t *vector_sub (object_t * vo, int start, int end) 140 | { 141 | vector_t *v = OVAL (vo); 142 | if (end == -1) 143 | end = v->len - 1; 144 | object_t *newv = c_vec (1 + end - start, NIL); 145 | int i; 146 | for (i = start; i <= end; i++) 147 | vset (newv, i - start, UPREF (vget (vo, i))); 148 | return newv; 149 | } 150 | 151 | uint32_t vector_hash (object_t * o) 152 | { 153 | uint32_t accum = 0; 154 | vector_t *v = OVAL (o); 155 | size_t i; 156 | for (i = 0; i < v->len; i++) 157 | accum ^= obj_hash (v->v[i]); 158 | return accum; 159 | } 160 | -------------------------------------------------------------------------------- /lib/object.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "common.h" 5 | #include "mem.h" 6 | #include "cons.h" 7 | #include "symtab.h" 8 | #include "str.h" 9 | #include "object.h" 10 | #include "number.h" 11 | #include "vector.h" 12 | #include "detach.h" 13 | 14 | static mmanager_t *mm; 15 | 16 | static void object_clear (void *o) 17 | { 18 | object_t *obj = (object_t *) o; 19 | obj->type = SYMBOL; 20 | obj->refs = 0; 21 | FVAL (obj) = NULL; 22 | OVAL (obj) = NIL; 23 | } 24 | 25 | void object_init () 26 | { 27 | mm = mm_create (sizeof (object_t), &object_clear); 28 | } 29 | 30 | object_t *obj_create (type_t type) 31 | { 32 | object_t *o = (object_t *) mm_alloc (mm); 33 | o->type = type; 34 | o->refs++; 35 | switch (type) 36 | { 37 | case INT: 38 | OVAL (o) = xmalloc (sizeof (mpz_t)); 39 | break; 40 | case FLOAT: 41 | OVAL (o) = xmalloc (sizeof (mpf_t)); 42 | break; 43 | case CONS: 44 | OVAL (o) = cons_create (); 45 | break; 46 | case SYMBOL: 47 | OVAL (o) = symbol_create (); 48 | break; 49 | case STRING: 50 | OVAL (o) = str_create (); 51 | break; 52 | case VECTOR: 53 | OVAL (o) = vector_create (); 54 | break; 55 | case DETACH: 56 | OVAL (o) = detach_create (); 57 | break; 58 | case CFUNC: 59 | case SPECIAL: 60 | break; 61 | } 62 | return o; 63 | } 64 | 65 | object_t *c_cons (object_t * car, object_t * cdr) 66 | { 67 | object_t *o = obj_create (CONS); 68 | CAR (o) = car; 69 | CDR (o) = cdr; 70 | return o; 71 | } 72 | 73 | object_t *c_cfunc (cfunc_t f) 74 | { 75 | object_t *o = obj_create (CFUNC); 76 | FVAL (o) = f; 77 | return o; 78 | } 79 | 80 | object_t *c_special (cfunc_t f) 81 | { 82 | object_t *o = obj_create (SPECIAL); 83 | FVAL (o) = f; 84 | return o; 85 | } 86 | 87 | void obj_destroy (object_t * o) 88 | { 89 | if (SYMBOLP (o)) 90 | return; 91 | o->refs--; 92 | if (o->refs > 0) 93 | return; 94 | 95 | mpz_t *z; 96 | mpf_t *f; 97 | switch (o->type) 98 | { 99 | case SYMBOL: 100 | /* Symbol objects are never destroyed. */ 101 | return; 102 | case FLOAT: 103 | f = OFLOAT (o); 104 | mpf_clear (*f); 105 | xfree (OVAL (o)); 106 | break; 107 | case INT: 108 | z = OINT (o); 109 | mpz_clear (*z); 110 | xfree (OVAL (o)); 111 | break; 112 | case STRING: 113 | str_destroy (OVAL (o)); 114 | break; 115 | case CONS: 116 | obj_destroy (CAR (o)); 117 | obj_destroy (CDR (o)); 118 | cons_destroy (OVAL (o)); 119 | break; 120 | case VECTOR: 121 | vector_destroy (OVAL (o)); 122 | break; 123 | case DETACH: 124 | detach_destroy (o); 125 | xfree (OVAL (o)); 126 | break; 127 | case CFUNC: 128 | case SPECIAL: 129 | break; 130 | } 131 | mm_free (mm, (void *) o); 132 | } 133 | 134 | void obj_print (object_t * o, int newline) 135 | { 136 | switch (o->type) 137 | { 138 | case CONS: 139 | printf ("("); 140 | object_t *p = o; 141 | while (p->type == CONS) 142 | { 143 | obj_print (CAR (p), 0); 144 | p = CDR (p); 145 | if (p->type == CONS) 146 | printf (" "); 147 | } 148 | if (p != NIL) 149 | { 150 | printf (" . "); 151 | obj_print (p, 0); 152 | } 153 | printf (")"); 154 | break; 155 | case INT: 156 | gmp_printf ("%Zd", OINT (o)); 157 | break; 158 | case FLOAT: 159 | gmp_printf ("%.Ff", OFLOAT (o)); 160 | break; 161 | case STRING: 162 | printf ("%s", OSTRP (o)); 163 | break; 164 | case SYMBOL: 165 | printf ("%s", ((symbol_t *) OVAL (o))->name); 166 | break; 167 | case VECTOR: 168 | vec_print (o); 169 | break; 170 | case DETACH: 171 | detach_print (o); 172 | break; 173 | case CFUNC: 174 | /* It's not possible to print a function pointer. */ 175 | printf (""); 176 | break; 177 | case SPECIAL: 178 | /* It's not possible to print a function pointer. */ 179 | printf (""); 180 | break; 181 | default: 182 | printf ("ERROR"); 183 | } 184 | 185 | if (newline) 186 | printf ("\n"); 187 | } 188 | 189 | uint32_t obj_hash (object_t * o) 190 | { 191 | switch (o->type) 192 | { 193 | case CONS: 194 | return cons_hash (o); 195 | case INT: 196 | return int_hash (o); 197 | break; 198 | case FLOAT: 199 | return float_hash (o); 200 | break; 201 | case STRING: 202 | return str_hash (o); 203 | break; 204 | case SYMBOL: 205 | return symbol_hash (o); 206 | break; 207 | case VECTOR: 208 | return vector_hash (o); 209 | break; 210 | case DETACH: 211 | return detach_hash (o); 212 | break; 213 | case CFUNC: 214 | case SPECIAL: 215 | /* Imprecise, but close enough */ 216 | return hash (OVAL (o), sizeof (void *)); 217 | break; 218 | } 219 | return 0; 220 | } 221 | 222 | uint32_t hash (void *key, size_t keylen) 223 | { 224 | /* One-at-a-time hash */ 225 | uint32_t hash, i; 226 | for (hash = 0, i = 0; i < keylen; ++i) 227 | { 228 | hash += ((char *) key)[i]; 229 | hash += (hash << 10); 230 | hash ^= (hash >> 6); 231 | } 232 | hash += (hash << 3); 233 | hash ^= (hash >> 11); 234 | hash += (hash << 15); 235 | return hash; 236 | } 237 | -------------------------------------------------------------------------------- /lib/hashtab.c: -------------------------------------------------------------------------------- 1 | /* hashtab.c - simple hashtable */ 2 | 3 | #include 4 | #include 5 | #include 6 | #include "common.h" 7 | #include "hashtab.h" 8 | 9 | hashtab_t *ht_init (size_t size, int (*hash_func) (void *, size_t, size_t)) 10 | { 11 | hashtab_t *new_ht = (hashtab_t *) xmalloc (sizeof (hashtab_t)); 12 | new_ht->arr = 13 | (hashtab_node_t **) xmalloc (sizeof (hashtab_node_t *) * size); 14 | new_ht->size = size; 15 | new_ht->count = 0; 16 | 17 | /* all entries are empty */ 18 | int i = 0; 19 | for (i = 0; i < (int) size; i++) 20 | new_ht->arr[i] = NULL; 21 | 22 | if (hash_func == NULL) 23 | new_ht->hash_func = &ht_hash; 24 | else 25 | new_ht->hash_func = hash_func; 26 | 27 | return new_ht; 28 | } 29 | 30 | void *ht_search (hashtab_t * hashtable, void *key, size_t keylen) 31 | { 32 | int index = ht_hash (key, keylen, hashtable->size); 33 | if (hashtable->arr[index] == NULL) 34 | return NULL; 35 | 36 | hashtab_node_t *last_node = hashtable->arr[index]; 37 | while (last_node != NULL) 38 | { 39 | if (last_node->keylen == keylen) 40 | if (memcmp (key, last_node->key, keylen) == 0) 41 | return last_node->value; 42 | last_node = last_node->next; 43 | } 44 | return NULL; 45 | } 46 | 47 | void *ht_insert (hashtab_t * hashtable, 48 | void *key, size_t keylen, void *value, size_t vallen) 49 | { 50 | int index = ht_hash (key, keylen, hashtable->size); 51 | 52 | hashtab_node_t *next_node, *last_node; 53 | next_node = hashtable->arr[index]; 54 | last_node = NULL; 55 | 56 | /* Search for an existing key. */ 57 | while (next_node != NULL) 58 | { 59 | if (next_node->keylen == keylen) 60 | { 61 | if (memcmp (key, next_node->key, keylen) == 0) 62 | { 63 | next_node->value = value; 64 | next_node->vallen = vallen; 65 | return next_node->value; 66 | } 67 | } 68 | last_node = next_node; 69 | next_node = next_node->next; 70 | } 71 | 72 | /* create a new node */ 73 | hashtab_node_t *new_node; 74 | new_node = (hashtab_node_t *) xmalloc (sizeof (hashtab_node_t)); 75 | new_node->key = key; 76 | new_node->value = value; 77 | new_node->keylen = keylen; 78 | new_node->vallen = vallen; 79 | new_node->next = NULL; 80 | 81 | /* Tack the new node on the end or right on the table. */ 82 | if (last_node != NULL) 83 | last_node->next = new_node; 84 | else 85 | hashtable->arr[index] = new_node; 86 | 87 | hashtable->count++; 88 | return new_node->value; 89 | } 90 | 91 | /* delete the given key from the hashtable */ 92 | void ht_remove (hashtab_t * hashtable, void *key, size_t keylen) 93 | { 94 | hashtab_node_t *last_node, *next_node; 95 | int index = ht_hash (key, keylen, hashtable->size); 96 | next_node = hashtable->arr[index]; 97 | last_node = NULL; 98 | 99 | while (next_node != NULL) 100 | { 101 | if (next_node->keylen == keylen) 102 | { 103 | if (memcmp (key, next_node->key, keylen) == 0) 104 | { 105 | /* adjust the list pointers */ 106 | if (last_node != NULL) 107 | last_node->next = next_node->next; 108 | else 109 | hashtable->arr[index] = next_node->next; 110 | 111 | /* free the node */ 112 | xfree (next_node); 113 | break; 114 | } 115 | } 116 | last_node = next_node; 117 | next_node = next_node->next; 118 | } 119 | } 120 | 121 | /* grow the hashtable */ 122 | hashtab_t *ht_grow (hashtab_t * old_ht, size_t new_size) 123 | { 124 | /* create new hashtable */ 125 | hashtab_t *new_ht = ht_init (new_size, old_ht->hash_func); 126 | if (new_ht == NULL) 127 | return NULL; 128 | 129 | /* Iterate through the old hashtable. */ 130 | hashtab_iter_t ii; 131 | ht_iter_init (old_ht, &ii); 132 | for (; ii.key != NULL; ht_iter_inc (&ii)) 133 | ht_insert (new_ht, ii.key, ii.keylen, ii.value, ii.vallen); 134 | 135 | /* Destroy the old hashtable. */ 136 | ht_destroy (old_ht); 137 | 138 | return new_ht; 139 | } 140 | 141 | /* free all resources used by the hashtable */ 142 | void ht_destroy (hashtab_t * hashtable) 143 | { 144 | hashtab_node_t *next_node, *last_node; 145 | 146 | /* Free each linked list in hashtable. */ 147 | int i; 148 | for (i = 0; i < (int) hashtable->size; i++) 149 | { 150 | next_node = hashtable->arr[i]; 151 | while (next_node != NULL) 152 | { 153 | /* destroy node */ 154 | last_node = next_node; 155 | next_node = next_node->next; 156 | xfree (last_node); 157 | } 158 | } 159 | 160 | xfree (hashtable->arr); 161 | xfree (hashtable); 162 | } 163 | 164 | /* iterator initilaize */ 165 | void ht_iter_init (hashtab_t * hashtable, hashtab_iter_t * ii) 166 | { 167 | /* stick in initial bookeeping data */ 168 | ii->internal.hashtable = hashtable; 169 | ii->internal.node = NULL; 170 | ii->internal.index = -1; 171 | 172 | /* have iterator point to first element */ 173 | ht_iter_inc (ii); 174 | } 175 | 176 | /* iterator increment */ 177 | void ht_iter_inc (hashtab_iter_t * ii) 178 | { 179 | hashtab_t *hashtable = ii->internal.hashtable; 180 | int index = ii->internal.index; 181 | 182 | /* attempt to grab the next node */ 183 | if (ii->internal.node == NULL || ii->internal.node->next == NULL) 184 | index++; 185 | else 186 | { 187 | /* next node in the list */ 188 | ii->internal.node = ii->internal.node->next; 189 | ii->key = ii->internal.node->key; 190 | ii->value = ii->internal.node->value; 191 | ii->keylen = ii->internal.node->keylen; 192 | ii->vallen = ii->internal.node->vallen; 193 | return; 194 | } 195 | 196 | /* find next node */ 197 | while (hashtable->arr[index] == NULL && index < (int) hashtable->size) 198 | index++; 199 | 200 | if (index >= (int) hashtable->size) 201 | { 202 | /* end of hashtable */ 203 | ii->internal.node = NULL; 204 | ii->internal.index = (int) hashtable->size; 205 | 206 | ii->key = NULL; 207 | ii->value = NULL; 208 | ii->keylen = 0; 209 | ii->vallen = 0; 210 | return; 211 | } 212 | 213 | /* point to the next item in the hashtable */ 214 | ii->internal.node = hashtable->arr[index]; 215 | ii->internal.index = index; 216 | ii->key = ii->internal.node->key; 217 | ii->value = ii->internal.node->value; 218 | ii->keylen = ii->internal.node->keylen; 219 | ii->vallen = ii->internal.node->vallen; 220 | } 221 | 222 | int ht_hash (void *key, size_t keylen, size_t hashtab_size) 223 | { 224 | /* One-at-a-time hash */ 225 | uint32_t hash, i; 226 | for (hash = 0, i = 0; i < keylen; ++i) 227 | { 228 | hash += ((char *) key)[i]; 229 | hash += (hash << 10); 230 | hash ^= (hash >> 6); 231 | } 232 | hash += (hash << 3); 233 | hash ^= (hash >> 11); 234 | hash += (hash << 15); 235 | return (hash % hashtab_size); 236 | } 237 | -------------------------------------------------------------------------------- /lib/lisp_math.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include "wisp.h" 4 | 5 | typedef enum arith_enum 6 | { ADD, SUB, MUL, DIV } arith_t; 7 | 8 | typedef enum cmp_enum 9 | { EQ, LT, LTE, GT, GTE, } cmp_t; 10 | 11 | /* Maths */ 12 | object_t *arith (arith_t op, object_t * lst) 13 | { 14 | if (op == DIV) 15 | REQM (lst, 2, c_sym ("div")); 16 | int intmode = 1; 17 | object_t *accumz = NIL, *accumf = NIL, *convf = c_float (0); 18 | switch (op) 19 | { 20 | case SUB: 21 | case ADD: 22 | accumz = c_int (0); 23 | accumf = c_float (0); 24 | break; 25 | case MUL: 26 | case DIV: 27 | accumz = c_int (1); 28 | accumf = c_float (1); 29 | break; 30 | } 31 | if (op == SUB || op == DIV) 32 | { 33 | object_t *num = CAR (lst); 34 | if (FLOATP (num)) 35 | { 36 | intmode = 0; 37 | mpf_set (DFLOAT (accumf), DFLOAT (num)); 38 | } 39 | else if (INTP (num)) 40 | { 41 | mpf_set_z (DFLOAT (accumf), DINT (num)); 42 | mpz_set (DINT (accumz), DINT (num)); 43 | } 44 | else 45 | { 46 | obj_destroy (accumz); 47 | obj_destroy (accumf); 48 | obj_destroy (convf); 49 | THROW (wrong_type, UPREF (num)); 50 | } 51 | if (op == SUB && CDR (lst) == NIL) 52 | { 53 | if (intmode) 54 | { 55 | obj_destroy (accumf); 56 | obj_destroy (convf); 57 | mpz_neg (DINT (accumz), DINT (accumz)); 58 | return accumz; 59 | } 60 | else 61 | { 62 | obj_destroy (accumz); 63 | obj_destroy (convf); 64 | mpf_neg (DFLOAT (accumf), DFLOAT (accumf)); 65 | return accumf; 66 | } 67 | } 68 | lst = CDR (lst); 69 | } 70 | 71 | while (lst != NIL) 72 | { 73 | object_t *num = CAR (lst); 74 | if (!NUMP (num)) 75 | { 76 | obj_destroy (accumz); 77 | obj_destroy (accumf); 78 | obj_destroy (convf); 79 | THROW (wrong_type, UPREF (num)); 80 | } 81 | /* Check divide by zero */ 82 | if (op == DIV) 83 | { 84 | double dnum; 85 | if (FLOATP (num)) 86 | dnum = floato2float (num); 87 | else 88 | dnum = into2int (num); 89 | if (dnum == 0) 90 | { 91 | obj_destroy (accumz); 92 | obj_destroy (accumf); 93 | obj_destroy (convf); 94 | THROW (c_sym ("divide-by-zero"), UPREF (num)); 95 | } 96 | } 97 | 98 | if (intmode) 99 | { 100 | if (FLOATP (num)) 101 | { 102 | intmode = 0; 103 | mpf_set_z (DFLOAT (accumf), DINT (accumz)); 104 | /* Fall through to !intmode */ 105 | } 106 | else if (INTP (num)) 107 | { 108 | switch (op) 109 | { 110 | case ADD: 111 | mpz_add (DINT (accumz), DINT (accumz), DINT (CAR (lst))); 112 | break; 113 | case MUL: 114 | mpz_mul (DINT (accumz), DINT (accumz), DINT (CAR (lst))); 115 | break; 116 | case SUB: 117 | mpz_sub (DINT (accumz), DINT (accumz), DINT (CAR (lst))); 118 | break; 119 | case DIV: 120 | mpz_div (DINT (accumz), DINT (accumz), DINT (CAR (lst))); 121 | break; 122 | } 123 | } 124 | } 125 | if (!intmode) 126 | { 127 | if (FLOATP (num)) 128 | switch (op) 129 | { 130 | case ADD: 131 | mpf_add (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (num)); 132 | break; 133 | case MUL: 134 | mpf_mul (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (num)); 135 | break; 136 | case SUB: 137 | mpf_sub (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (num)); 138 | break; 139 | case DIV: 140 | mpf_div (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (num)); 141 | break; 142 | } 143 | else if (INTP (num)) 144 | { 145 | /* Convert to float and add. */ 146 | mpf_set_z (DFLOAT (convf), DINT (num)); 147 | switch (op) 148 | { 149 | case ADD: 150 | mpf_add (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (convf)); 151 | break; 152 | case MUL: 153 | mpf_mul (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (convf)); 154 | break; 155 | case SUB: 156 | mpf_sub (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (convf)); 157 | break; 158 | case DIV: 159 | mpf_div (DFLOAT (accumf), DFLOAT (accumf), DFLOAT (convf)); 160 | break; 161 | } 162 | } 163 | } 164 | lst = CDR (lst); 165 | } 166 | obj_destroy (convf); 167 | 168 | /* Destroy whatever went unused. */ 169 | if (intmode) 170 | { 171 | obj_destroy (accumf); 172 | return accumz; 173 | } 174 | obj_destroy (accumz); 175 | return accumf; 176 | } 177 | 178 | object_t *addition (object_t * lst) 179 | { 180 | DOC ("Perform addition operation."); 181 | return arith (ADD, lst); 182 | } 183 | 184 | object_t *multiplication (object_t * lst) 185 | { 186 | DOC ("Perform multiplication operation."); 187 | return arith (MUL, lst); 188 | } 189 | 190 | object_t *subtraction (object_t * lst) 191 | { 192 | DOC ("Perform subtraction operation."); 193 | return arith (SUB, lst); 194 | } 195 | 196 | object_t *division (object_t * lst) 197 | { 198 | DOC ("Perform division operation."); 199 | return arith (DIV, lst); 200 | } 201 | 202 | object_t *num_cmp (cmp_t cmp, object_t * lst) 203 | { 204 | REQM (lst, 2, c_sym ("compare-func")); 205 | object_t *a = CAR (lst); 206 | object_t *b = CAR (CDR (lst)); 207 | if (!NUMP (a)) 208 | THROW (wrong_type, UPREF (a)); 209 | if (!NUMP (b)) 210 | THROW (wrong_type, UPREF (b)); 211 | int r = 0, invr = 1; 212 | if (INTP (a) && INTP (b)) 213 | r = mpz_cmp (DINT (a), DINT (b)); 214 | else if (FLOATP (a) && FLOATP (b)) 215 | r = mpf_cmp (DFLOAT (a), DFLOAT (b)); 216 | else if (INTP (a) && FLOATP (b)) 217 | { 218 | /* Swap and handle below. */ 219 | object_t *c = b; 220 | b = a; 221 | a = c; 222 | invr = -1; 223 | } 224 | if (FLOATP (a) && INTP (b)) 225 | { 226 | /* Convert down. */ 227 | object_t *convf = c_float (0); 228 | mpf_set_z (DFLOAT (convf), DINT (b)); 229 | r = mpf_cmp (DFLOAT (a), DFLOAT (convf)); 230 | obj_destroy (convf); 231 | } 232 | r *= invr; 233 | switch (cmp) 234 | { 235 | case EQ: 236 | r = (0 == r); 237 | break; 238 | case LT: 239 | r = (r < 0); 240 | break; 241 | case LTE: 242 | r = (r <= 0); 243 | break; 244 | case GT: 245 | r = (r > 0); 246 | break; 247 | case GTE: 248 | r = (r >= 0); 249 | break; 250 | } 251 | if (r) 252 | return T; 253 | return NIL; 254 | } 255 | 256 | object_t *num_eq (object_t * lst) 257 | { 258 | DOC ("Compare two numbers by =."); 259 | return num_cmp (EQ, lst); 260 | } 261 | 262 | object_t *num_lt (object_t * lst) 263 | { 264 | DOC ("Compare two numbers by <."); 265 | return num_cmp (LT, lst); 266 | } 267 | 268 | object_t *num_lte (object_t * lst) 269 | { 270 | DOC ("Compare two numbers by <=."); 271 | return num_cmp (LTE, lst); 272 | } 273 | 274 | object_t *num_gt (object_t * lst) 275 | { 276 | DOC ("Compare two numbers by >."); 277 | return num_cmp (GT, lst); 278 | } 279 | 280 | object_t *num_gte (object_t * lst) 281 | { 282 | DOC ("Compare two numbers by >=."); 283 | return num_cmp (GTE, lst); 284 | } 285 | 286 | object_t *modulus (object_t * lst) 287 | { 288 | DOC ("Return modulo of arguments."); 289 | REQ (lst, 2, c_sym ("%")); 290 | object_t *a = CAR (lst); 291 | object_t *b = CAR (CDR (lst)); 292 | if (!INTP (a)) 293 | THROW (wrong_type, UPREF (a)); 294 | if (!INTP (b)) 295 | THROW (wrong_type, UPREF (b)); 296 | object_t *m = c_int (0); 297 | mpz_mod (DINT (m), DINT (a), DINT (b)); 298 | return m; 299 | } 300 | 301 | /* Install all the math functions */ 302 | void lisp_math_init () 303 | { 304 | SSET (c_sym ("+"), c_cfunc (&addition)); 305 | SSET (c_sym ("*"), c_cfunc (&multiplication)); 306 | SSET (c_sym ("-"), c_cfunc (&subtraction)); 307 | SSET (c_sym ("/"), c_cfunc (&division)); 308 | SSET (c_sym ("="), c_cfunc (&num_eq)); 309 | SSET (c_sym ("<"), c_cfunc (&num_lt)); 310 | SSET (c_sym ("<="), c_cfunc (&num_lte)); 311 | SSET (c_sym (">"), c_cfunc (&num_gt)); 312 | SSET (c_sym (">="), c_cfunc (&num_gte)); 313 | SSET (c_sym ("%"), c_cfunc (&modulus)); 314 | } 315 | -------------------------------------------------------------------------------- /lib/eval.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "cons.h" 6 | #include "object.h" 7 | #include "symtab.h" 8 | #include "eval.h" 9 | #include "number.h" 10 | #include "str.h" 11 | #include "reader.h" 12 | #include "common.h" 13 | #include "lisp.h" 14 | #include "vector.h" 15 | 16 | object_t *lambda, *macro, *quote; 17 | object_t *err_symbol, *err_thrown, *err_attach; 18 | object_t *rest, *optional; 19 | object_t *doc_string; 20 | /* Commonly used thrown error symbols */ 21 | object_t *void_function, *wrong_number_of_arguments, *wrong_type, 22 | *improper_list, *improper_list_ending, *err_interrupt; 23 | 24 | /* Stack counting */ 25 | unsigned int stack_depth = 0, max_stack_depth = 20000; 26 | 27 | char *core_file = "core.wisp"; 28 | 29 | int interrupt = 0; 30 | int interactive_mode = 0; 31 | void handle_iterrupt (int sig) 32 | { 33 | (void) sig; 34 | if (!interrupt && interactive_mode) 35 | { 36 | interrupt = 1; 37 | signal (SIGINT, &handle_iterrupt); 38 | } 39 | else 40 | { 41 | signal (SIGINT, SIG_DFL); 42 | raise (SIGINT); 43 | } 44 | } 45 | 46 | void eval_init () 47 | { 48 | /* install interrupt handler */ 49 | signal (SIGINT, &handle_iterrupt); 50 | 51 | /* regular evaluation symbols */ 52 | lambda = c_sym ("lambda"); 53 | macro = c_sym ("macro"); 54 | quote = c_sym ("quote"); 55 | rest = c_sym ("&rest"); 56 | optional = c_sym ("&optional"); 57 | doc_string = c_sym ("doc-string"); 58 | 59 | /* error symbols */ 60 | err_symbol = c_usym ("wisp-error"); 61 | SET (err_symbol, err_symbol); 62 | err_thrown = err_attach = NIL; 63 | void_function = c_sym ("void-function"); 64 | wrong_number_of_arguments = c_sym ("wrong-number-of-arguments"); 65 | wrong_type = c_sym ("wrong-type-argument"); 66 | improper_list = c_sym ("improper-list"); 67 | improper_list_ending = c_sym ("improper-list-ending"); 68 | err_interrupt = c_sym ("caught-interrupt"); 69 | 70 | /* set up wisproot */ 71 | wisproot = getenv ("WISPROOT"); 72 | if (wisproot == NULL) 73 | wisproot = "."; 74 | SET (c_sym ("wisproot"), c_strs (xstrdup (wisproot))); 75 | 76 | /* Load core lisp code. */ 77 | if (strlen (wisproot) != 0) 78 | core_file = pathcat (wisproot, core_file); 79 | int r = load_file (NULL, core_file, 0); 80 | if (!r) 81 | { 82 | fprintf (stderr, "error: could not load core lisp \"%s\": %s\n", 83 | core_file, strerror (errno)); 84 | if (strlen (wisproot) == 1) 85 | fprintf (stderr, "warning: perhaps you should set WISPROOT\n"); 86 | exit (EXIT_FAILURE); 87 | } 88 | } 89 | 90 | /* Initilize all the systems. */ 91 | void wisp_init () 92 | { 93 | /* These *must* be called in this order. */ 94 | object_init (); 95 | symtab_init (); 96 | cons_init (); 97 | str_init (); 98 | lisp_init (); 99 | vector_init (); 100 | eval_init (); 101 | } 102 | 103 | object_t *eval_list (object_t * lst) 104 | { 105 | if (lst == NIL) 106 | return NIL; 107 | if (!CONSP (lst)) 108 | THROW (improper_list_ending, UPREF (lst)); 109 | object_t *car = eval (CAR (lst)); 110 | CHECK (car); 111 | object_t *cdr = eval_list (CDR (lst)); 112 | if (cdr == err_symbol) 113 | { 114 | obj_destroy (car); 115 | return err_symbol; 116 | } 117 | return c_cons (car, cdr); 118 | } 119 | 120 | object_t *eval_body (object_t * body) 121 | { 122 | object_t *r = NIL; 123 | while (body != NIL) 124 | { 125 | obj_destroy (r); 126 | r = eval (CAR (body)); 127 | CHECK (r); 128 | body = CDR (body); 129 | } 130 | return r; 131 | } 132 | 133 | object_t *assign_args (object_t * vars, object_t * vals) 134 | { 135 | int optional_mode = 0; 136 | int cnt = 0; 137 | object_t *orig_vars = vars; 138 | while (vars != NIL) 139 | { 140 | object_t *var = CAR (vars); 141 | if (var == optional) 142 | { 143 | /* Turn on optional mode and continue. */ 144 | optional_mode = 1; 145 | vars = CDR (vars); 146 | continue; 147 | } 148 | if (var == rest) 149 | { 150 | /* Assign the rest of the list and finish. */ 151 | vars = CDR (vars); 152 | sympush (CAR (vars), vals); 153 | vals = NIL; 154 | break; 155 | } 156 | else if (!optional_mode && vals == NIL) 157 | { 158 | while (cnt > 0) 159 | { 160 | sympop (CAR (orig_vars)); 161 | orig_vars = CDR (orig_vars); 162 | cnt--; 163 | } 164 | THROW (wrong_number_of_arguments, NIL); 165 | } 166 | else if (optional_mode && vals == NIL) 167 | { 168 | sympush (var, NIL); 169 | } 170 | else 171 | { 172 | object_t *val = CAR (vals); 173 | sympush (var, val); 174 | cnt++; 175 | } 176 | vars = CDR (vars); 177 | if (vals != NIL) 178 | vals = CDR (vals); 179 | } 180 | 181 | /* vals should be consumed by now */ 182 | if (vals != NIL) 183 | { 184 | unassign_args (vars); 185 | THROW (wrong_number_of_arguments, NIL); 186 | } 187 | return T; 188 | } 189 | 190 | void unassign_args (object_t * vars) 191 | { 192 | if (vars == NIL) 193 | return; 194 | object_t *var = CAR (vars); 195 | if (var != rest && var != optional) 196 | sympop (var); 197 | unassign_args (CDR (vars)); 198 | } 199 | 200 | object_t *top_eval (object_t * o) 201 | { 202 | stack_depth = 0; 203 | object_t *r = eval (o); 204 | if (r == err_symbol) 205 | { 206 | printf ("Wisp error: "); 207 | object_t *c = c_cons (err_thrown, c_cons (err_attach, NIL)); 208 | obj_print (c, 1); 209 | obj_destroy (c); 210 | return err_symbol; 211 | } 212 | return r; 213 | } 214 | 215 | object_t *eval (object_t * o) 216 | { 217 | /* Check for interrupts. */ 218 | if (interrupt) 219 | { 220 | interrupt = 0; 221 | THROW (err_interrupt, c_strs (xstrdup ("interrupted"))); 222 | } 223 | 224 | if (o->type != CONS && o->type != SYMBOL) 225 | return UPREF (o); 226 | else if (o->type == SYMBOL) 227 | return UPREF (GET (o)); 228 | 229 | /* Find the function. */ 230 | object_t *f = eval (CAR (o)); 231 | CHECK (f); 232 | object_t *extrao = NIL; 233 | if (VECTORP (f)) 234 | { 235 | extrao = o = c_cons (UPREF (f), UPREF (o)); 236 | f = eval (c_sym ("vfunc")); 237 | if (f == err_symbol) 238 | { 239 | obj_destroy (extrao); 240 | return err_symbol; 241 | } 242 | } 243 | if (!FUNCP (f)) 244 | { 245 | obj_destroy (f); 246 | THROW (void_function, UPREF (CAR (o))); 247 | } 248 | 249 | /* Check the stack */ 250 | if (++stack_depth >= max_stack_depth) 251 | THROW (c_sym ("max-eval-depth"), c_int (stack_depth--)); 252 | 253 | /* Handle argument list */ 254 | object_t *args = CDR (o); 255 | if (f->type == CFUNC || (f->type == CONS && (CAR (f) == lambda))) 256 | { 257 | /* c function or list function (eval args) */ 258 | args = eval_list (args); 259 | if (args == err_symbol) 260 | { 261 | obj_destroy (f); 262 | obj_destroy (extrao); 263 | return err_symbol; 264 | } 265 | } 266 | else 267 | UPREF (args); /* so we can destroy args no matter what */ 268 | 269 | object_t *ret = apply (f, args); 270 | stack_depth--; 271 | obj_destroy (f); 272 | obj_destroy (args); 273 | obj_destroy (extrao); /* vector as function */ 274 | return ret; 275 | } 276 | 277 | object_t *apply (object_t * f, object_t * args) 278 | { 279 | if (f->type == CFUNC || f->type == SPECIAL) 280 | { 281 | /* call the c function */ 282 | cfunc_t cf = FVAL (f); 283 | object_t *r = cf (args); 284 | return r; 285 | } 286 | else 287 | { 288 | /* list form */ 289 | object_t *vars = CAR (CDR (f)); 290 | object_t *assr = assign_args (vars, args); 291 | if (assr == err_symbol) 292 | { 293 | err_attach = UPREF (args); 294 | return err_symbol; 295 | } 296 | object_t *r; 297 | if (CAR (f) == lambda) 298 | r = eval_body (CDR (CDR (f))); 299 | else 300 | { 301 | object_t *body = eval_body (CDR (CDR (f))); 302 | r = eval (body); 303 | obj_destroy (body); 304 | } 305 | unassign_args (vars); 306 | return r; 307 | } 308 | return NIL; 309 | } 310 | -------------------------------------------------------------------------------- /lib/reader.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "object.h" 5 | #include "symtab.h" 6 | #include "common.h" 7 | #include "cons.h" 8 | #include "eval.h" 9 | #include "str.h" 10 | #include "reader.h" 11 | #include "number.h" 12 | #include "vector.h" 13 | 14 | static void read_error (reader_t * r, char *str); 15 | static void addpop (reader_t * r); 16 | static void reset (reader_t * r); 17 | 18 | char *wisproot = NULL; 19 | 20 | char *atom_chars = 21 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" 22 | "0123456789!#$%^&*-_=+|\\/?.~<>"; 23 | char *prompt = "wisp> "; 24 | 25 | reader_t *reader_create (FILE * fid, char *str, char *name, int interactive) 26 | { 27 | reader_t *r = xmalloc (sizeof (reader_t)); 28 | r->fid = fid; 29 | r->strp = r->str = str; 30 | r->name = name ? name : ""; 31 | r->interactive = interactive; 32 | r->prompt = prompt; 33 | r->linecnt = 1; 34 | r->eof = 0; 35 | r->error = 0; 36 | r->shebang = -1 + interactive; 37 | r->done = 0; 38 | 39 | /* read buffers */ 40 | r->buflen = 1024; 41 | r->bufp = r->buf = xmalloc (r->buflen + 1); 42 | r->readbuflen = 8; 43 | r->readbufp = r->readbuf = xmalloc (r->readbuflen * sizeof (int)); 44 | 45 | /* state stack */ 46 | r->ssize = 32; 47 | r->base = r->state = xmalloc (r->ssize * sizeof (rstate_t)); 48 | return r; 49 | } 50 | 51 | void reader_destroy (reader_t * r) 52 | { 53 | reset (r); 54 | xfree (r->buf); 55 | xfree (r->readbuf); 56 | xfree (r->base); 57 | xfree (r); 58 | } 59 | 60 | /* Read next character in the stream. */ 61 | static int reader_getc (reader_t * r) 62 | { 63 | int c; 64 | if (r->readbufp > r->readbuf) 65 | { 66 | c = *(r->readbufp); 67 | r->readbufp--; 68 | return c; 69 | } 70 | if (r->str != NULL) 71 | { 72 | c = *(r->strp); 73 | if (c != '\0') 74 | r->strp++; 75 | else 76 | return EOF; 77 | } 78 | else 79 | c = fgetc (r->fid); 80 | return c; 81 | } 82 | 83 | /* Unread a byte. */ 84 | static void reader_putc (reader_t * r, int c) 85 | { 86 | r->readbufp++; 87 | if (r->readbufp == r->readbuf + r->readbuflen) 88 | { 89 | r->readbuflen *= 2; 90 | r->readbuf = xrealloc (r->readbuf, sizeof (int) * r->readbuflen); 91 | r->readbufp = r->readbuf + r->readbuflen / 2; 92 | } 93 | *(r->readbufp) = c; 94 | } 95 | 96 | /* Consume remaining whitespace on line, including linefeed. */ 97 | static void consume_whitespace (reader_t * r) 98 | { 99 | int c = reader_getc (r); 100 | while (strchr (" \t\r", c) != NULL) 101 | c = reader_getc (r); 102 | if (c != '\n') 103 | reader_putc (r, c); 104 | } 105 | 106 | /* Consume remaining characters on line, including linefeed. */ 107 | static void consume_line (reader_t * r) 108 | { 109 | int c = reader_getc (r); 110 | while (c != '\n' && c != EOF) 111 | c = reader_getc (r); 112 | if (c != '\n') 113 | reader_putc (r, c); 114 | } 115 | 116 | /* Return height of sexp stack. */ 117 | static size_t stack_height (reader_t * r) 118 | { 119 | return (r->state - r->base); 120 | } 121 | 122 | /* Push new list onto the sexp stack. */ 123 | static void push (reader_t * r) 124 | { 125 | r->state++; 126 | if (r->state == r->base + r->ssize) 127 | { 128 | r->ssize *= 2; 129 | r->base = xrealloc (r->base, sizeof (rstate_t *) * r->ssize); 130 | r->state = r->base + r->ssize / 2; 131 | } 132 | /* clear the state */ 133 | r->state->quote_mode = 0; 134 | r->state->dotpair_mode = 0; 135 | r->state->vector_mode = 0; 136 | r->state->head = r->state->tail = c_cons (NIL, NIL); 137 | } 138 | 139 | /* Remove top object from the sexp stack. */ 140 | static object_t *pop (reader_t * r) 141 | { 142 | if (!r->done && stack_height (r) <= 1) 143 | { 144 | read_error (r, "unbalanced parenthesis"); 145 | return err_symbol; 146 | } 147 | if (!r->done && r->state->dotpair_mode == 1) 148 | { 149 | read_error (r, "missing cdr object for dotted pair"); 150 | return err_symbol; 151 | } 152 | object_t *p = CDR (r->state->head); 153 | CDR (r->state->head) = NIL; 154 | obj_destroy (r->state->head); 155 | if (r->state->vector_mode) 156 | { 157 | r->state--; 158 | object_t *v = list2vector (p); 159 | obj_destroy (p); 160 | return v; 161 | } 162 | r->state--; 163 | return p; 164 | } 165 | 166 | static void reset_buf (reader_t * r) 167 | { 168 | r->bufp = r->buf; 169 | *(r->bufp) = '\0'; 170 | } 171 | 172 | /* Remove top object from the sexp stack. */ 173 | static void reset (reader_t * r) 174 | { 175 | r->done = 1; 176 | while (r->state != r->base) 177 | obj_destroy (pop (r)); 178 | reset_buf (r); 179 | r->readbufp = r->readbuf; 180 | r->done = 0; 181 | } 182 | 183 | /* Print an error message. */ 184 | static void read_error (reader_t * r, char *str) 185 | { 186 | fprintf (stderr, "%s:%d: %s\n", r->name, r->linecnt, str); 187 | consume_line (r); 188 | reset (r); 189 | r->error = 1; 190 | } 191 | 192 | /* Determine if top list is empty. */ 193 | static int list_empty (reader_t * r) 194 | { 195 | return CDR (r->state->head) == NIL; 196 | } 197 | 198 | static void print_prompt (reader_t * r) 199 | { 200 | if (r->interactive && stack_height (r) == 1) 201 | printf ("%s", r->prompt); 202 | } 203 | 204 | /* Push a new object into the current list. */ 205 | static void add (reader_t * r, object_t * o) 206 | { 207 | if (r->state->dotpair_mode == 2) 208 | { 209 | /* CDR already filled. Cannot add more. */ 210 | read_error (r, "invalid dotted pair syntax - too many objects"); 211 | return; 212 | } 213 | 214 | if (!r->state->dotpair_mode) 215 | { 216 | CDR (r->state->tail) = c_cons (o, NIL); 217 | r->state->tail = CDR (r->state->tail); 218 | if (r->state->quote_mode) 219 | addpop (r); 220 | } 221 | else 222 | { 223 | CDR (r->state->tail) = o; 224 | r->state->dotpair_mode = 2; 225 | if (r->state->quote_mode) 226 | addpop (r); 227 | } 228 | } 229 | 230 | /* Pop sexp stack and add it to the new top list. */ 231 | static void addpop (reader_t * r) 232 | { 233 | object_t *o = pop (r); 234 | if (!r->error) 235 | add (r, o); 236 | } 237 | 238 | /* Append character to buffer. */ 239 | static void buf_append (reader_t * r, char c) 240 | { 241 | if (r->bufp == r->buf + r->buflen) 242 | { 243 | r->buflen *= 2; 244 | r->buf = xrealloc (r->buf, r->buflen + 1); 245 | r->bufp = r->buf + r->buflen / 2; 246 | } 247 | *(r->bufp) = c; 248 | *(r->bufp + 1) = '\0'; 249 | r->bufp++; 250 | } 251 | 252 | /* Load into buffer until character, ignoring escaped ones. */ 253 | static int buf_read (reader_t * r, char *halt) 254 | { 255 | int esc = 0; 256 | int c = reader_getc (r); 257 | esc = 0; 258 | if (c == '\\') 259 | { 260 | c = reader_getc (r); 261 | esc = 1; 262 | } 263 | while ((esc || strchr (halt, c) == NULL) && (c != EOF)) 264 | { 265 | buf_append (r, c); 266 | c = reader_getc (r); 267 | esc = 0; 268 | if (c == '\\') 269 | { 270 | c = reader_getc (r); 271 | esc = 1; 272 | } 273 | } 274 | reader_putc (r, c); 275 | return !esc; 276 | } 277 | 278 | /* Turn string in buffer into string object. */ 279 | static object_t *parse_str (reader_t * r) 280 | { 281 | size_t size = r->bufp - r->buf; 282 | char *str = xstrdup (r->buf); 283 | reset_buf (r); 284 | return c_str (str, size); 285 | } 286 | 287 | /* Turn string in buffer into atom object. */ 288 | static object_t *parse_atom (reader_t * r) 289 | { 290 | char *str = r->buf; 291 | char *end; 292 | 293 | /* Detect integer */ 294 | int i = strtol (str, &end, 10); 295 | (void) i; 296 | if (end != str && *end == '\0') 297 | { 298 | object_t *o = c_ints (str); 299 | reset_buf (r); 300 | return o; 301 | } 302 | 303 | /* Detect float */ 304 | int d = strtod (str, &end); 305 | (void) d; 306 | if (end != str && *end == '\0') 307 | { 308 | object_t *o = c_floats (str); 309 | reset_buf (r); 310 | return o; 311 | } 312 | 313 | /* Might be a symbol then */ 314 | char *p = r->buf; 315 | while (p <= r->bufp) 316 | { 317 | if (strchr (atom_chars, *p) == NULL) 318 | { 319 | char *errstr = xstrdup ("invalid symbol character: X"); 320 | errstr[strlen (errstr) - 1] = *p; 321 | read_error (r, errstr); 322 | xfree (errstr); 323 | return NIL; 324 | } 325 | p++; 326 | } 327 | object_t *o = c_sym (r->buf); 328 | reset_buf (r); 329 | return o; 330 | } 331 | 332 | /* Read a single sexp from the reader. */ 333 | object_t *read_sexp (reader_t * r) 334 | { 335 | /* Check for a shebang line. */ 336 | if (r->shebang == -1) 337 | { 338 | char str[2]; 339 | str[0] = reader_getc (r); 340 | str[1] = reader_getc (r); 341 | if (str[0] == '#' && str[1] == '!') 342 | { 343 | /* Looks like a she-bang line. */ 344 | r->shebang = 1; 345 | consume_line (r); 346 | } 347 | else 348 | { 349 | r->shebang = 0; 350 | reader_putc (r, str[1]); 351 | reader_putc (r, str[0]); 352 | } 353 | } 354 | 355 | r->done = 0; 356 | r->error = 0; 357 | push (r); 358 | print_prompt (r); 359 | while (!r->eof && !r->error && (list_empty (r) || stack_height (r) > 1)) 360 | { 361 | int nc, c = reader_getc (r); 362 | switch (c) 363 | { 364 | case EOF: 365 | r->eof = 1; 366 | break; 367 | 368 | /* Comments */ 369 | case ';': 370 | consume_line (r); 371 | break; 372 | 373 | /* Dotted pair */ 374 | case '.': 375 | nc = reader_getc (r); 376 | if (strchr (" \t\r\n()", nc) != NULL) 377 | { 378 | if (r->state->dotpair_mode > 0) 379 | read_error (r, "invalid dotted pair syntax"); 380 | else if (r->state->vector_mode > 0) 381 | read_error (r, "dotted pair not allowed in vector"); 382 | else 383 | { 384 | r->state->dotpair_mode = 1; 385 | reader_putc (r, nc); 386 | } 387 | } 388 | else 389 | { 390 | /* Turn it into a decimal point. */ 391 | reader_putc (r, nc); 392 | reader_putc (r, '.'); 393 | reader_putc (r, '0'); 394 | } 395 | break; 396 | 397 | /* Whitespace */ 398 | case '\n': 399 | r->linecnt++; 400 | print_prompt (r); 401 | case ' ': 402 | case '\t': 403 | case '\r': 404 | break; 405 | 406 | /* Parenthesis */ 407 | case '(': 408 | push (r); 409 | break; 410 | case ')': 411 | if (r->state->quote_mode) 412 | read_error (r, "unbalanced parenthesis"); 413 | else if (r->state->vector_mode) 414 | read_error (r, "unbalanced brackets"); 415 | else 416 | addpop (r); 417 | break; 418 | 419 | /* Vectors */ 420 | case '[': 421 | push (r); 422 | r->state->vector_mode = 1; 423 | break; 424 | case ']': 425 | if (r->state->quote_mode) 426 | read_error (r, "unbalanced parenthesis"); 427 | else if (!r->state->vector_mode) 428 | read_error (r, "unbalanced brackets"); 429 | else 430 | addpop (r); 431 | break; 432 | 433 | /* Quoting */ 434 | case '\'': 435 | push (r); 436 | add (r, quote); 437 | if (!r->error) 438 | r->state->quote_mode = 1; 439 | break; 440 | 441 | /* strings */ 442 | case '"': 443 | buf_read (r, "\""); 444 | add (r, parse_str (r)); 445 | reader_getc (r); /* Throw away other quote. */ 446 | break; 447 | 448 | /* numbers and symbols */ 449 | default: 450 | buf_append (r, c); 451 | buf_read (r, " \t\r\n()[];"); 452 | object_t *o = parse_atom (r); 453 | if (!r->error) 454 | add (r, o); 455 | break; 456 | } 457 | } 458 | if (!r->eof && !r->error) 459 | consume_whitespace (r); 460 | if (r->error) 461 | return err_symbol; 462 | 463 | /* Check state */ 464 | r->done = 1; 465 | if (stack_height (r) > 1 || r->state->quote_mode 466 | || r->state->dotpair_mode == 1) 467 | { 468 | read_error (r, "premature end of file"); 469 | return err_symbol; 470 | } 471 | if (list_empty (r)) 472 | { 473 | obj_destroy (pop (r)); 474 | return NIL; 475 | } 476 | 477 | object_t *wrap = pop (r); 478 | object_t *sexp = UPREF (CAR (wrap)); 479 | obj_destroy (wrap); 480 | return sexp; 481 | } 482 | 483 | /* Use the core functions above to eval each sexp in a file. */ 484 | int load_file (FILE * fid, char *filename, int interactive) 485 | { 486 | if (fid == NULL) 487 | { 488 | fid = fopen (filename, "r"); 489 | if (fid == NULL) 490 | return 0; 491 | } 492 | reader_t *r = reader_create (fid, NULL, filename, interactive); 493 | while (!r->eof) 494 | { 495 | object_t *sexp = read_sexp (r); 496 | if (sexp != err_symbol) 497 | { 498 | object_t *ret = top_eval (sexp); 499 | if (r->interactive && ret != err_symbol) 500 | obj_print (ret, 1); 501 | obj_destroy (sexp); 502 | obj_destroy (ret); 503 | } 504 | } 505 | reader_destroy (r); 506 | return 1; 507 | } 508 | 509 | /* Convenience function for creating a REPL. */ 510 | void repl () 511 | { 512 | interactive_mode = 1; 513 | load_file (stdin, "", 1); 514 | } 515 | -------------------------------------------------------------------------------- /lib/lisp.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include "object.h" 6 | #include "cons.h" 7 | #include "symtab.h" 8 | #include "common.h" 9 | #include "eval.h" 10 | #include "str.h" 11 | #include "reader.h" 12 | #include "number.h" 13 | #include "vector.h" 14 | #include "detach.h" 15 | 16 | /* From lisp_math.c */ 17 | void lisp_math_init (); 18 | object_t *num_eq (object_t * lst); 19 | 20 | /* Various basic stuff */ 21 | 22 | object_t *cdoc_string (object_t * lst) 23 | { 24 | DOC ("Return doc-string for CFUNC or SPECIAL."); 25 | REQ (lst, 1, c_sym ("cdoc-string")); 26 | object_t *fo = CAR (lst); 27 | int evaled = 0; 28 | if (SYMBOLP (fo)) 29 | { 30 | evaled = 1; 31 | fo = eval (fo); 32 | } 33 | if (fo->type != CFUNC && fo->type != SPECIAL) 34 | { 35 | if (evaled) 36 | obj_destroy (fo); 37 | THROW (wrong_type, UPREF (fo)); 38 | } 39 | cfunc_t f = FVAL (fo); 40 | object_t *str = f (doc_string); 41 | if (evaled) 42 | obj_destroy (fo); 43 | return str; 44 | } 45 | 46 | object_t *lisp_apply (object_t * lst) 47 | { 48 | DOC ("Apply function to a list."); 49 | REQ (lst, 2, c_sym ("apply")); 50 | object_t *f = CAR (lst); 51 | object_t *args = CAR (CDR (lst)); 52 | if (!LISTP (args)) 53 | THROW (wrong_type, UPREF (args)); 54 | return apply (f, args); 55 | } 56 | 57 | object_t *lisp_and (object_t * lst) 58 | { 59 | DOC ("Evaluate each argument until one returns nil."); 60 | object_t *r = T, *p = lst; 61 | while (CONSP (p)) 62 | { 63 | obj_destroy (r); 64 | r = eval (CAR (p)); 65 | CHECK (r); 66 | if (r == NIL) 67 | return NIL; 68 | p = CDR (p); 69 | } 70 | if (p != NIL) 71 | THROW (improper_list, UPREF (lst)); 72 | return UPREF (r); 73 | } 74 | 75 | object_t *lisp_or (object_t * lst) 76 | { 77 | DOC ("Evaluate each argument until one doesn't return nil."); 78 | object_t *r = NIL, *p = lst; 79 | while (CONSP (p)) 80 | { 81 | r = eval (CAR (p)); 82 | CHECK (r); 83 | if (r != NIL) 84 | return UPREF (r); 85 | p = CDR (p); 86 | } 87 | if (p != NIL) 88 | THROW (improper_list, UPREF (lst)); 89 | return NIL; 90 | } 91 | 92 | object_t *lisp_cons (object_t * lst) 93 | { 94 | DOC ("Construct a new cons cell, given car and cdr."); 95 | REQ (lst, 2, c_sym ("cons")); 96 | return c_cons (UPREF (CAR (lst)), UPREF (CAR (CDR (lst)))); 97 | } 98 | 99 | object_t *lisp_quote (object_t * lst) 100 | { 101 | DOC ("Return argument unevaluated."); 102 | REQ (lst, 1, c_sym ("quote")); 103 | return UPREF (CAR (lst)); 104 | } 105 | 106 | object_t *lambda_f (object_t * lst) 107 | { 108 | DOC ("Create an anonymous function."); 109 | if (!is_func_form (lst)) 110 | THROW (c_sym ("bad-function-form"), UPREF (lst)); 111 | return c_cons (lambda, UPREF (lst)); 112 | } 113 | 114 | object_t *defun (object_t * lst) 115 | { 116 | DOC ("Define a new function."); 117 | if (!SYMBOLP (CAR (lst)) || !is_func_form (CDR (lst))) 118 | THROW (c_sym ("bad-function-form"), UPREF (lst)); 119 | object_t *f = c_cons (lambda, UPREF (CDR (lst))); 120 | SET (CAR (lst), f); 121 | return UPREF (CAR (lst)); 122 | } 123 | 124 | object_t *defmacro (object_t * lst) 125 | { 126 | DOC ("Define a new macro."); 127 | if (!SYMBOLP (CAR (lst)) || !is_func_form (CDR (lst))) 128 | THROW (c_sym ("bad-function-form"), UPREF (lst)); 129 | object_t *f = c_cons (macro, UPREF (CDR (lst))); 130 | SET (CAR (lst), f); 131 | return UPREF (CAR (lst)); 132 | } 133 | 134 | object_t *lisp_cdr (object_t * lst) 135 | { 136 | DOC ("Return cdr element of cons cell."); 137 | REQ (lst, 1, c_sym ("cdr")); 138 | if (CAR (lst) == NIL) 139 | return NIL; 140 | if (!LISTP (CAR (lst))) 141 | THROW (wrong_type, CAR (lst)); 142 | return UPREF (CDR (CAR (lst))); 143 | } 144 | 145 | object_t *lisp_car (object_t * lst) 146 | { 147 | DOC ("Return car element of cons cell."); 148 | REQ (lst, 1, c_sym ("car")); 149 | if (CAR (lst) == NIL) 150 | return NIL; 151 | if (!LISTP (CAR (lst))) 152 | THROW (wrong_type, CAR (lst)); 153 | return UPREF (CAR (CAR (lst))); 154 | } 155 | 156 | object_t *lisp_list (object_t * lst) 157 | { 158 | DOC ("Return arguments as a list."); 159 | return UPREF (lst); 160 | } 161 | 162 | object_t *lisp_if (object_t * lst) 163 | { 164 | DOC ("If conditional special form."); 165 | REQM (lst, 2, wrong_number_of_arguments); 166 | object_t *r = eval (CAR (lst)); 167 | CHECK (r); 168 | if (r != NIL) 169 | { 170 | obj_destroy (r); 171 | return eval (CAR (CDR (lst))); 172 | } 173 | return eval_body (CDR (CDR (lst))); 174 | } 175 | 176 | object_t *lisp_cond (object_t * lst) 177 | { 178 | DOC ("Eval car of each argument until one is true. Then eval cdr of\n" 179 | "that argument."); 180 | object_t *p = lst; 181 | while (p != NIL) 182 | { 183 | if (!CONSP (p)) 184 | THROW (improper_list, UPREF (lst)); 185 | object_t *pair = CAR (p); 186 | if (!CONSP (pair)) 187 | THROW (wrong_type, UPREF (pair)); 188 | if (!LISTP (CDR (pair))) 189 | THROW (improper_list, UPREF (pair)); 190 | if (CDR (pair) == NIL) 191 | return UPREF (CAR (pair)); 192 | if (CDR (CDR (pair)) != NIL) 193 | THROW (c_sym ("bad-form"), UPREF (pair)); 194 | object_t *r = eval (CAR (pair)); 195 | if (r != NIL) 196 | { 197 | obj_destroy (r); 198 | return eval (CAR (CDR (pair))); 199 | } 200 | p = CDR (p); 201 | } 202 | return NIL; 203 | } 204 | 205 | object_t *progn (object_t * lst) 206 | { 207 | DOC ("Eval each argument and return the eval of the last."); 208 | return eval_body (lst); 209 | } 210 | 211 | object_t *let (object_t * lst) 212 | { 213 | DOC ("Create variable bindings in a new scope, and eval " 214 | "body in that scope."); 215 | /* verify structure */ 216 | if (!LISTP (CAR (lst))) 217 | THROW (c_sym ("bad-let-form"), UPREF (lst)); 218 | object_t *vlist = CAR (lst); 219 | while (vlist != NIL) 220 | { 221 | object_t *p = CAR (vlist); 222 | if (!LISTP (p)) 223 | THROW (c_sym ("bad-let-form"), UPREF (lst)); 224 | if (!SYMBOLP (CAR (p))) 225 | THROW (c_sym ("bad-let-form"), UPREF (lst)); 226 | vlist = CDR (vlist); 227 | } 228 | 229 | object_t *p; 230 | p = vlist = CAR (lst); 231 | int cnt = 0; 232 | while (p != NIL) 233 | { 234 | object_t *pair = CAR (p); 235 | object_t *e = eval (CAR (CDR (pair))); 236 | if (e == err_symbol) 237 | { 238 | /* Undo scoping */ 239 | p = vlist; 240 | while (cnt) 241 | { 242 | sympop (CAR (CAR (p))); 243 | p = CDR (p); 244 | cnt--; 245 | } 246 | return err_symbol; 247 | } 248 | sympush (CAR (pair), e); 249 | obj_destroy (e); 250 | p = CDR (p); 251 | cnt++; 252 | } 253 | object_t *r = eval_body (CDR (lst)); 254 | p = vlist; 255 | while (p != NIL) 256 | { 257 | object_t *pair = CAR (p); 258 | sympop (CAR (pair)); 259 | p = CDR (p); 260 | } 261 | return r; 262 | } 263 | 264 | object_t *lisp_while (object_t * lst) 265 | { 266 | DOC ("Continually evaluate body until first argument evals nil."); 267 | REQM (lst, 1, c_sym ("while")); 268 | object_t *r = NIL, *cond = CAR (lst), *body = CDR (lst); 269 | object_t *condr; 270 | while ((condr = eval (cond)) != NIL) 271 | { 272 | obj_destroy (r); 273 | obj_destroy (condr); 274 | CHECK (condr); 275 | r = eval_body (body); 276 | } 277 | return r; 278 | } 279 | 280 | /* Equality */ 281 | 282 | object_t *eq (object_t * lst) 283 | { 284 | DOC ("Return t if both arguments are the same lisp object."); 285 | REQ (lst, 2, c_sym ("eq")); 286 | object_t *a = CAR (lst); 287 | object_t *b = CAR (CDR (lst)); 288 | if (a == b) 289 | return T; 290 | return NIL; 291 | } 292 | 293 | object_t *eql (object_t * lst) 294 | { 295 | DOC ("Return t if both arguments are similar."); 296 | REQ (lst, 2, c_sym ("eql")); 297 | object_t *a = CAR (lst); 298 | object_t *b = CAR (CDR (lst)); 299 | if (a->type != b->type) 300 | return NIL; 301 | switch (a->type) 302 | { 303 | case INT: 304 | case FLOAT: 305 | return num_eq (lst); 306 | break; 307 | case SYMBOL: 308 | case CONS: 309 | if (a == b) 310 | return T; 311 | break; 312 | case STRING: 313 | if (OSTRLEN (a) == OSTRLEN (b)) 314 | if (memcmp (OSTR (a), OSTR (b), OSTRLEN (a)) == 0) 315 | return T; 316 | break; 317 | case VECTOR: 318 | return NIL; 319 | break; 320 | case DETACH: 321 | if (a == b) 322 | return T; 323 | break; 324 | case CFUNC: 325 | case SPECIAL: 326 | if (FVAL (a) == FVAL (b)) 327 | return T; 328 | break; 329 | } 330 | return NIL; 331 | } 332 | 333 | object_t *lisp_hash (object_t * lst) 334 | { 335 | DOC ("Return integer hash of object."); 336 | REQ (lst, 1, c_sym ("hash")); 337 | return c_int (obj_hash (CAR (lst))); 338 | } 339 | 340 | object_t *lisp_print (object_t * lst) 341 | { 342 | DOC ("Print object or sexp in parse-able form."); 343 | REQ (lst, 1, c_sym ("print")); 344 | obj_print (CAR (lst), 1); 345 | return NIL; 346 | } 347 | 348 | /* Symbol table */ 349 | 350 | object_t *lisp_set (object_t * lst) 351 | { 352 | DOC ("Store object in symbol."); 353 | REQ (lst, 2, c_sym ("set")); 354 | if (!SYMBOLP (CAR (lst))) 355 | THROW (wrong_type, c_cons (c_sym ("set"), CAR (lst))); 356 | if (CONSTANTP (CAR (lst))) 357 | THROW (c_sym ("setting-constant"), CAR (lst)); 358 | 359 | SET (CAR (lst), CAR (CDR (lst))); 360 | return UPREF (CAR (CDR (lst))); 361 | } 362 | 363 | object_t *lisp_value (object_t * lst) 364 | { 365 | DOC ("Get value stored in symbol."); 366 | REQ (lst, 1, c_sym ("value")); 367 | if (!SYMBOLP (CAR (lst))) 368 | THROW (wrong_type, c_cons (c_sym ("value"), CAR (lst))); 369 | 370 | return UPREF (GET (CAR (lst))); 371 | } 372 | 373 | object_t *symbol_name (object_t * lst) 374 | { 375 | DOC ("Return symbol name as string."); 376 | REQ (lst, 1, c_sym ("symbol-name")); 377 | if (!SYMBOLP (CAR (lst))) 378 | THROW (wrong_type, UPREF (CAR (lst))); 379 | return c_strs (xstrdup (SYMNAME (CAR (lst)))); 380 | } 381 | 382 | /* String */ 383 | 384 | object_t *lisp_concat (object_t * lst) 385 | { 386 | DOC ("Concatenate two strings."); 387 | REQ (lst, 2, c_sym ("concat")); 388 | object_t *a = CAR (lst); 389 | object_t *b = CAR (CDR (lst)); 390 | if (!STRINGP (a)) 391 | THROW (wrong_type, UPREF (a)); 392 | if (!STRINGP (b)) 393 | THROW (wrong_type, UPREF (b)); 394 | return str_cat (a, b); 395 | } 396 | 397 | /* Predicates */ 398 | 399 | object_t *nullp (object_t * lst) 400 | { 401 | DOC ("Return t if object is nil."); 402 | REQ (lst, 1, c_sym ("nullp")); 403 | if (CAR (lst) == NIL) 404 | return T; 405 | return NIL; 406 | } 407 | 408 | object_t *funcp (object_t * lst) 409 | { 410 | DOC ("Return t if object is a function."); 411 | REQ (lst, 1, c_sym ("funcp")); 412 | if (FUNCP (CAR (lst))) 413 | return T; 414 | return NIL; 415 | } 416 | 417 | object_t *listp (object_t * lst) 418 | { 419 | DOC ("Return t if object is a list."); 420 | REQ (lst, 1, c_sym ("listp")); 421 | if (LISTP (CAR (lst))) 422 | return T; 423 | return NIL; 424 | } 425 | 426 | object_t *symbolp (object_t * lst) 427 | { 428 | DOC ("Return t if object is a symbol."); 429 | REQ (lst, 1, c_sym ("symbolp")); 430 | if (SYMBOLP (CAR (lst))) 431 | return T; 432 | return NIL; 433 | } 434 | 435 | object_t *numberp (object_t * lst) 436 | { 437 | DOC ("Return t if object is a number."); 438 | REQ (lst, 1, c_sym ("numberp")); 439 | if (NUMP (CAR (lst))) 440 | return T; 441 | return NIL; 442 | } 443 | 444 | object_t *stringp (object_t * lst) 445 | { 446 | DOC ("Return t if object is a string."); 447 | REQ (lst, 1, c_sym ("stringp")); 448 | if (STRINGP (CAR (lst))) 449 | return T; 450 | return NIL; 451 | } 452 | 453 | object_t *integerp (object_t * lst) 454 | { 455 | DOC ("Return t if object is an integer."); 456 | REQ (lst, 1, c_sym ("integerp")); 457 | if (INTP (CAR (lst))) 458 | return T; 459 | return NIL; 460 | } 461 | 462 | object_t *floatp (object_t * lst) 463 | { 464 | DOC ("Return t if object is a floating-point number."); 465 | REQ (lst, 1, c_sym ("floatp")); 466 | if (FLOATP (CAR (lst))) 467 | return T; 468 | return NIL; 469 | } 470 | 471 | object_t *vectorp (object_t * lst) 472 | { 473 | DOC ("Return t if object is a vector."); 474 | REQ (lst, 1, c_sym ("vectorp")); 475 | if (VECTORP (CAR (lst))) 476 | return T; 477 | return NIL; 478 | } 479 | 480 | /* Input/Output */ 481 | 482 | object_t *lisp_load (object_t * lst) 483 | { 484 | DOC ("Evaluate contents of a file."); 485 | REQ (lst, 1, c_sym ("load")); 486 | object_t *str = CAR (lst); 487 | if (!STRINGP (str)) 488 | THROW (wrong_type, UPREF (str)); 489 | char *filename = OSTR (str); 490 | int r = load_file (NULL, filename, 0); 491 | if (!r) 492 | THROW (c_sym ("load-file-error"), UPREF (str)); 493 | return T; 494 | } 495 | 496 | object_t *lisp_read_string (object_t * lst) 497 | { 498 | DOC ("Parse a string into a sexp or list object."); 499 | REQ (lst, 1, c_sym ("eval-string")); 500 | object_t *stro = CAR (lst); 501 | if (!STRINGP (stro)) 502 | THROW (wrong_type, UPREF (stro)); 503 | char *str = OSTR (stro); 504 | reader_t *r = reader_create (NULL, str, "eval-string", 0); 505 | object_t *sexp = read_sexp (r); 506 | reader_destroy (r); 507 | if (sexp == err_symbol) 508 | THROW (c_sym ("parse-error"), UPREF (stro)); 509 | return sexp; 510 | } 511 | 512 | /* Error handling */ 513 | 514 | object_t *throw (object_t * lst) 515 | { 516 | DOC ("Throw an object, and attachment, as an exception."); 517 | THROW (UPREF (CAR (lst)), UPREF (CAR (CDR (lst)))); 518 | } 519 | 520 | object_t *catch (object_t * lst) 521 | { 522 | DOC ("Catch an exception and return attachment."); 523 | object_t *csym = eval (CAR (lst)); 524 | CHECK (csym); 525 | object_t *body = CDR (lst); 526 | object_t *r = eval_body (body); 527 | if (r == err_symbol) 528 | { 529 | if (csym == err_thrown) 530 | { 531 | obj_destroy (csym); 532 | obj_destroy (err_thrown); 533 | return err_attach; 534 | } 535 | else 536 | return err_symbol; 537 | } 538 | return r; 539 | } 540 | 541 | /* Vectors */ 542 | 543 | object_t *lisp_vset (object_t * lst) 544 | { 545 | DOC ("Set slot in a vector to object."); 546 | REQ (lst, 3, c_sym ("vset")); 547 | object_t *vec = CAR (lst); 548 | object_t *ind = CAR (CDR (lst)); 549 | object_t *val = CAR (CDR (CDR (lst))); 550 | if (!VECTORP (vec)) 551 | THROW (wrong_type, UPREF (vec)); 552 | if (!INTP (ind)) 553 | THROW (wrong_type, UPREF (ind)); 554 | return vset_check (vec, ind, val); 555 | } 556 | 557 | object_t *lisp_vget (object_t * lst) 558 | { 559 | DOC ("Get object stored in vector slot."); 560 | REQ (lst, 2, c_sym ("vget")); 561 | object_t *vec = CAR (lst); 562 | object_t *ind = CAR (CDR (lst)); 563 | if (!VECTORP (vec)) 564 | THROW (wrong_type, UPREF (vec)); 565 | if (!INTP (ind)) 566 | THROW (wrong_type, UPREF (ind)); 567 | return vget_check (vec, ind); 568 | } 569 | 570 | object_t *lisp_vlength (object_t * lst) 571 | { 572 | DOC ("Return length of the vector."); 573 | REQ (lst, 1, c_sym ("vlength")); 574 | object_t *vec = CAR (lst); 575 | if (!VECTORP (vec)) 576 | THROW (wrong_type, UPREF (vec)); 577 | return c_int (VLENGTH (vec)); 578 | } 579 | 580 | object_t *make_vector (object_t * lst) 581 | { 582 | DOC ("Make a new vector of given length, initialized to given object."); 583 | REQ (lst, 2, c_sym ("make-vector")); 584 | object_t *len = CAR (lst); 585 | object_t *o = CAR (CDR (lst)); 586 | if (!INTP (len)) 587 | THROW (wrong_type, UPREF (len)); 588 | return c_vec (into2int (len), o); 589 | } 590 | 591 | object_t *lisp_vconcat (object_t * lst) 592 | { 593 | DOC ("Concatenate two vectors."); 594 | REQ (lst, 2, c_sym ("vconcat2")); 595 | object_t *a = CAR (lst); 596 | object_t *b = CAR (CDR (lst)); 597 | if (!VECTORP (a)) 598 | THROW (wrong_type, UPREF (a)); 599 | if (!VECTORP (b)) 600 | THROW (wrong_type, UPREF (b)); 601 | return vector_concat (a, b); 602 | } 603 | 604 | object_t *lisp_vsub (object_t * lst) 605 | { 606 | DOC ("Return subsection of vector."); 607 | REQM (lst, 2, c_sym ("subv")); 608 | object_t *v = CAR (lst); 609 | object_t *starto = CAR (CDR (lst)); 610 | if (!VECTORP (v)) 611 | THROW (wrong_type, UPREF (v)); 612 | if (!INTP (starto)) 613 | THROW (wrong_type, UPREF (starto)); 614 | int start = into2int (starto); 615 | if (start >= (int) VLENGTH (v)) 616 | THROW (c_sym ("bad-index"), UPREF (starto)); 617 | if (start < 0) 618 | THROW (c_sym ("bad-index"), UPREF (starto)); 619 | if (CDR (CDR (lst)) == NIL) 620 | { 621 | /* to the end */ 622 | return vector_sub (v, start, -1); 623 | } 624 | object_t *endo = CAR (CDR (CDR (lst))); 625 | if (!INTP (endo)) 626 | THROW (wrong_type, UPREF (endo)); 627 | int end = into2int (endo); 628 | if (end >= (int) VLENGTH (v)) 629 | THROW (c_sym ("bad-index"), UPREF (endo)); 630 | if (end < start) 631 | THROW (c_sym ("bad-index"), UPREF (endo)); 632 | return vector_sub (v, start, end); 633 | } 634 | 635 | /* Internals */ 636 | 637 | object_t *lisp_refcount (object_t * lst) 638 | { 639 | DOC ("Return number of reference counts to object."); 640 | REQ (lst, 1, c_sym ("refcount")); 641 | return c_int (CAR (lst)->refs); 642 | } 643 | 644 | object_t *lisp_eval_depth (object_t * lst) 645 | { 646 | DOC ("Return the current evaluation depth."); 647 | REQ (lst, 0, c_sym ("eval-depth")); 648 | return c_int (stack_depth); 649 | } 650 | 651 | object_t *lisp_max_eval_depth (object_t * lst) 652 | { 653 | DOC ("Return or set the maximum evaluation depth."); 654 | REQX (lst, 1, c_sym ("max-eval-depth")); 655 | if (lst == NIL) 656 | return c_int (max_stack_depth); 657 | object_t *arg = CAR (lst); 658 | if (!INTP (arg)) 659 | THROW (wrong_type, UPREF (arg)); 660 | int new_depth = into2int (arg); 661 | if (new_depth < 10) 662 | return NIL; 663 | max_stack_depth = new_depth; 664 | return UPREF (arg); 665 | } 666 | 667 | /* System */ 668 | 669 | object_t *lisp_exit (object_t * lst) 670 | { 671 | DOC ("Halt the interpreter and return given integer."); 672 | REQX (lst, 1, c_sym ("exit")); 673 | if (lst == NIL) 674 | exit (EXIT_SUCCESS); 675 | if (!INTP (CAR (lst))) 676 | THROW (wrong_type, UPREF (CAR (lst))); 677 | exit (into2int (CAR (lst))); 678 | } 679 | 680 | /* Installs all of the above functions. */ 681 | void lisp_init () 682 | { 683 | /* Maths */ 684 | lisp_math_init (); 685 | 686 | /* Various */ 687 | SSET (c_sym ("cdoc-string"), c_cfunc (&cdoc_string)); 688 | SSET (c_sym ("apply"), c_cfunc (&lisp_apply)); 689 | SSET (c_sym ("and"), c_special (&lisp_and)); 690 | SSET (c_sym ("or"), c_special (&lisp_or)); 691 | SSET (c_sym ("quote"), c_special (&lisp_quote)); 692 | SSET (c_sym ("lambda"), c_special (&lambda_f)); 693 | SSET (c_sym ("defun"), c_special (&defun)); 694 | SSET (c_sym ("defmacro"), c_special (&defmacro)); 695 | SSET (c_sym ("car"), c_cfunc (&lisp_car)); 696 | SSET (c_sym ("cdr"), c_cfunc (&lisp_cdr)); 697 | SSET (c_sym ("list"), c_cfunc (&lisp_list)); 698 | SSET (c_sym ("if"), c_special (&lisp_if)); 699 | SSET (c_sym ("not"), c_cfunc (&nullp)); 700 | SSET (c_sym ("progn"), c_special (&progn)); 701 | SSET (c_sym ("let"), c_special (&let)); 702 | SSET (c_sym ("while"), c_special (&lisp_while)); 703 | SSET (c_sym ("eval"), c_cfunc (&eval_body)); 704 | SSET (c_sym ("print"), c_cfunc (&lisp_print)); 705 | SSET (c_sym ("cons"), c_cfunc (&lisp_cons)); 706 | SSET (c_sym ("cond"), c_special (&lisp_cond)); 707 | 708 | /* Symbol table */ 709 | SSET (c_sym ("set"), c_cfunc (&lisp_set)); 710 | SSET (c_sym ("value"), c_cfunc (&lisp_value)); 711 | SSET (c_sym ("symbol-name"), c_cfunc (&symbol_name)); 712 | 713 | /* Strings */ 714 | SSET (c_sym ("concat2"), c_cfunc (&lisp_concat)); 715 | 716 | /* Equality */ 717 | SSET (c_sym ("eq"), c_cfunc (&eq)); 718 | SSET (c_sym ("eql"), c_cfunc (&eql)); 719 | SSET (c_sym ("hash"), c_cfunc (&lisp_hash)); 720 | 721 | /* Predicates */ 722 | SSET (c_sym ("nullp"), c_cfunc (&nullp)); 723 | SSET (c_sym ("funcp"), c_cfunc (&funcp)); 724 | SSET (c_sym ("listp"), c_cfunc (&listp)); 725 | SSET (c_sym ("symbolp"), c_cfunc (&symbolp)); 726 | SSET (c_sym ("stringp"), c_cfunc (&stringp)); 727 | SSET (c_sym ("numberp"), c_cfunc (&numberp)); 728 | SSET (c_sym ("integerp"), c_cfunc (&integerp)); 729 | SSET (c_sym ("floatp"), c_cfunc (&floatp)); 730 | SSET (c_sym ("vectorp"), c_cfunc (&vectorp)); 731 | 732 | /* Input/Output */ 733 | SSET (c_sym ("load"), c_cfunc (&lisp_load)); 734 | SSET (c_sym ("read-string"), c_cfunc (&lisp_read_string)); 735 | 736 | /* Error handling */ 737 | SSET (c_sym ("throw"), c_cfunc (&throw)); 738 | SSET (c_sym ("catch"), c_special (&catch)); 739 | 740 | /* Vectors */ 741 | SSET (c_sym ("vset"), c_cfunc (&lisp_vset)); 742 | SSET (c_sym ("vget"), c_cfunc (&lisp_vget)); 743 | SSET (c_sym ("vlength"), c_cfunc (&lisp_vlength)); 744 | SSET (c_sym ("make-vector"), c_cfunc (&make_vector)); 745 | SSET (c_sym ("vconcat2"), c_cfunc (&lisp_vconcat)); 746 | SSET (c_sym ("vsub"), c_cfunc (&lisp_vsub)); 747 | 748 | /* Internals */ 749 | SSET (c_sym ("refcount"), c_cfunc (&lisp_refcount)); 750 | SSET (c_sym ("eval-depth"), c_cfunc (&lisp_eval_depth)); 751 | SSET (c_sym ("max-eval-depth"), c_cfunc (&lisp_max_eval_depth)); 752 | 753 | /* System */ 754 | SSET (c_sym ("exit"), c_cfunc (&lisp_exit)); 755 | 756 | /* Detachments */ 757 | SSET (c_sym ("detach"), c_cfunc (&lisp_detach)); 758 | SSET (c_sym ("receive"), c_cfunc (&lisp_receive)); 759 | SSET (c_sym ("send"), c_cfunc (&lisp_send)); 760 | } 761 | -------------------------------------------------------------------------------- /doc/wisp-guide.txt: -------------------------------------------------------------------------------- 1 | Wisp User Guide 2 | =============== 3 | Christopher Wellons 4 | :Author Initials: CCW 5 | 6 | Wisp is a dialect of the lisp family of programming languages. It is a 7 | dynamically typed lisp-1 with arbitrary precision numbers and memory 8 | managed by reference counting. The interpreter itself is written in C. 9 | 10 | Introduction 11 | ----------- 12 | Wisp is meant to be a lightweight, simple, experimental lisp 13 | implementation. 14 | 15 | This document is not a general lisp tutorial. Rather, it is meant to 16 | highlight Wisp's features, document its functions, and its differences 17 | from other lisps. To fully understand the Wisp programming language, 18 | the reader should already be familiar with lisp programming. In 19 | particular, users of Emacs lisp should find Wisp fairly comfortable. 20 | 21 | Getting Started 22 | ~~~~~~~~~~~~~~~ 23 | 24 | Building Wisp 25 | ^^^^^^^^^^^^^ 26 | 27 | To build Wisp, all you need is a C99 compiler, SCons, and the GNU 28 | Multiple Precision library (GMP). The compiler switches in the 29 | SConstruct file are geared towards gcc, so if you aren't using gcc you 30 | may need to set the +CC+ and +CFLAGS+ environmental variables. 31 | 32 | If you wish to build the documentation, you will also need AsciiDoc. 33 | 34 | Compiling stuff on Windows is so difficult you're on your own for 35 | that. 36 | 37 | Environment 38 | ^^^^^^^^^^^ 39 | 40 | After +wisp+ has been built, you will probably want to set the 41 | +WISPROOT+ environmental variable. This tells +wisp+ where to find 42 | it's defining Wisp sources, which are loaded each time it is run. If 43 | you intend on running +wisp+ outside of the build directory, you will 44 | need to set this. Mine looks like this, with a bourne shell, 45 | 46 | ----------------- 47 | export WISPROOT=~/src/wisp 48 | ----------------- 49 | 50 | Using Wisp 51 | ---------- 52 | 53 | Wisp Modes 54 | ~~~~~~~~~~ 55 | 56 | There are two ways to run Wisp: on a Wisp source file or 57 | interactively. The former allows you to run scripts as standalone 58 | programs and the latter is good for doing software development. 59 | 60 | Interaction Mode 61 | ^^^^^^^^^^^^^^^^ 62 | 63 | If you run Wisp without any file name arguments, it will run 64 | interactively providing a prompt. Each s-expression is evaluated after 65 | it has been entirely entered. 66 | 67 | ---------- 68 | wisp> 69 | wisp> (+ 4 6 11) 70 | 21 71 | wisp> 72 | ---------- 73 | 74 | Interactive mode can be forced with the +-i+ switch. 75 | 76 | TIP: Wisp doesn't use a readline library, so it may be cumbersome to 77 | use interactive mode directly. Two ways to deal with this are with 78 | rlwrap, or by running it as an inferior lisp in Emacs. 79 | 80 | If you're using Emacs, +lisp-interaction-mode+ is very suitable for 81 | editing Wisp code, so this may be a useful thing to add to your 82 | +.emacs+. 83 | 84 | ---------- 85 | (add-to-list 'auto-mode-alist '(".wisp\\'" . lisp-interaction-mode)) 86 | ---------- 87 | 88 | Script Mode 89 | ^^^^^^^^^^^ 90 | 91 | Wisp supports the she-bang line, so you can place one at the top of 92 | the source file, indicating the path to +wisp+ (assuming +WISPROOT+ is 93 | set too), and execute the file directly. 94 | 95 | -------------- 96 | #!/usr/bin/wisp 97 | 98 | (print ARGS) 99 | -------------- 100 | 101 | You can also give the file name to +wisp+ on the command line. All 102 | arguments before the file name go to +wisp+ and all the arguments after 103 | go to the running Wisp program. These arguments are available as a 104 | list in the +ARGS+ variable. 105 | 106 | The Wisp Language 107 | ~~~~~~~~~~~~~~~~~ 108 | 109 | Types 110 | ^^^^^ 111 | 112 | Wisp currently has seven types: integer, floating point, strings, 113 | symbols, cons cells, CFUNCs, and special forms. The last two can only 114 | be defined and created in built-in C source code. 115 | 116 | All types, except symbols and cons cells, evaluate to 117 | themselves. Symbols evaluate to the object stored inside and cons 118 | cells are evaluated as lisp code. 119 | 120 | Numbers 121 | +++++++ 122 | 123 | Integers are GMP arbitrary precision integers. The parser detects 124 | integers with +strtol+, so it must look like an integer to this C 125 | function. 126 | 127 | Floating-point numbers are GMP floating-point numbers, with variable 128 | mantissa precision. 129 | 130 | Only when floating point numbers are involved in a math operation (*, 131 | /, +, -) will a floating point will be returned. Division with 132 | integers will result in integer division. However, many math functions 133 | will always return floating point numbers (cos, sin, etc.). 134 | 135 | Strings 136 | +++++++ 137 | 138 | Strings are stored internally as byte arrays, which are _not_ 139 | nul-terminated. When parsed, they need to be surrounded by quotes, and 140 | any internal backslashes or quotes must be escaped by a backslash. 141 | 142 | Symbols 143 | +++++++ 144 | 145 | Symbols are strings of characters without quotes, but with more 146 | limitation. The list of permitted characters in symbol names can be 147 | found in +reader.h+. 148 | 149 | Cons cells 150 | ++++++++++ 151 | 152 | Cons cells are that familiar glue that hold everything together. It 153 | has two cell, +car+ and +cdr+, which reference one other object 154 | each. The +car+ and +cdr+ functions will return each cell 155 | respectively. Wisp functions and macros are not a special type of 156 | their own, but are just lists made of cons cells. 157 | 158 | Vectors 159 | +++++++ 160 | 161 | Unlike lists, vectors have O(1) access time. However, once created 162 | they have a fixed size. Any type of lisp object can be stored in an 163 | vector, including other vectors, allowing for multi-demensional 164 | structures. 165 | 166 | CFUNCs and special forms 167 | ++++++++++++++++++++++++ 168 | 169 | CFUNCs and special forms are actually pointers into the C code, which 170 | allow C space to be exposed to the lisp space. You can't create or 171 | modify these without modifying the Wisp C source code. 172 | 173 | Syntax 174 | ^^^^^^ 175 | 176 | Like most lisps, there's not a whole lot of syntax. Anything between 177 | parenthesis makes a list. 178 | 179 | ------------- 180 | (a b c d) 181 | ------------- 182 | 183 | This includes other lists, 184 | 185 | ------------- 186 | (a b (x y z) c d) 187 | ------------- 188 | 189 | However, if you enter this directly it will be evaluated, producing an 190 | error. To prevent a list from being evaluated, it can be quoted, 191 | tucked inside the +quote+ function, 192 | 193 | ------------- 194 | (quote (a b (x y z) c d)) 195 | ------------- 196 | 197 | Since this needs to be done a lot, Wisp supports the quoting syntactic 198 | sugar, 199 | 200 | ------------- 201 | '(a b (x y z) c d) 202 | ------------- 203 | 204 | This works on individual symbols too, 205 | 206 | ------------- 207 | (set 'a "Hello") 208 | ------------- 209 | 210 | Wisp does not yet support back quotes and its advanced features used a 211 | lot by macros. 212 | 213 | Comments are done with semicolons, 214 | 215 | ------------- 216 | '(a b c) ; This is a comment 217 | ------------- 218 | 219 | Symbols 220 | ^^^^^^^ 221 | 222 | The symbols +t+ and +nil+ are predefined and evaluate to 223 | themselves. In conditionals, +nil+ evaluates to false. Anything else 224 | evaluates to true. +nil+ is also used to end lists. It's the +NULL+ 225 | pointer in lisp space. 226 | 227 | ------- 228 | wisp> (cdr '(a)) 229 | nil 230 | ------- 231 | 232 | All possible symbols are automatically binded globally, usually to 233 | +nil+, by default. This sets Wisp apart from other lisps. All symbols 234 | are also interned, so there is only one instance of any given symbol. 235 | 236 | All symbols with beginning with a colon are defined to 237 | themselves. This is useful in making property lists. 238 | 239 | -------- 240 | wisp> :hello 241 | :hello 242 | -------- 243 | 244 | Functions 245 | ^^^^^^^^^ 246 | 247 | The +defun+ special form is used to define functions. The syntax is 248 | the same as Emacs lisp. It will actually produce a +lambda+ anonymous 249 | function and tuck it away inside the indicated symbol (as well as 250 | return it). For example, 251 | 252 | ------------------------------- 253 | wisp> (defun square (x) 254 | (* x x)) 255 | square 256 | wisp> square 257 | (lambda (x) (* x x)) 258 | wisp> (square 6) 259 | 36 260 | ------------------------------- 261 | 262 | Since Wisp is a lisp-1, +square+ is just a variable containing the 263 | function. You can look at any function like this. However, CFUNCs and 264 | special forms will only give you the pointer address, 265 | 266 | ------------- 267 | wisp> + 268 | 269 | wisp> defun 270 | 271 | ------------- 272 | 273 | Functions must always be called with the proper number of arguments 274 | are an error will occur. To make a function more flexible about this, 275 | you can use +&optional+ and +&rest+ in your function 276 | definition. Anything following +&optional+ is optional, and will be 277 | defined to +nil+ when not provided. 278 | 279 | ------------------------------------ 280 | wisp> (defun args (a &optional b) 281 | b) 282 | args 283 | wisp> (args 1) 284 | nil 285 | wisp> (args 1 2) 286 | 2 287 | ------------------------------------ 288 | 289 | When +&rest+ is used, all remaining arguments are assigned to the 290 | symbol after +&rest+. 291 | 292 | ---------------------- 293 | wisp> (defun args (a &rest b) 294 | b) 295 | args 296 | wisp> (args 1 2) 297 | (2) 298 | wisp> (args 1 2 3 4) 299 | (2 3 4) 300 | ---------------------- 301 | 302 | Anonymous Functions 303 | +++++++++++++++++++ 304 | 305 | Anonymous functions work just like +defun+, except that they use 306 | +lambda+ and lack a name. 307 | 308 | --------------- 309 | (lambda (a b) (+ a b)) 310 | --------------- 311 | 312 | Non-anonymous functions are really just anonymous functions stuffed 313 | inside a symbol. 314 | 315 | Macros 316 | ^^^^^^ 317 | 318 | Wisp supports powerful lisp macros. They are defined with 319 | +defmacro+. For example, 320 | 321 | ------------- 322 | (defmacro setq (var val) 323 | (list 'set (list 'quote var) val)) 324 | ------------- 325 | 326 | It is treated exactly like a function, except that it's arguments are 327 | never evaluated and its return value is directly evaluated. 328 | 329 | There is no support for non-interned symbols (yet?), so macros may be 330 | limited in their usefulness. 331 | 332 | Error handling 333 | ^^^^^^^^^^^^^^ 334 | 335 | Error handling works by an exception throwing system. Any object can 336 | be thrown as any time with the +throw+ function. That object can be 337 | caught with +catch+ higher up on the stack. If nothing catches the 338 | thrown object, the stack will unwind all the way and the error shown 339 | to the user. The attached object will generally be information telling 340 | the user what was wrong. It could be a string, or the invalid argument 341 | in the case of a +wrong-argument-type+ error. 342 | 343 | Since you can also attach another object to a thrown object, in 344 | general you will only want to throw symbols. For example, to throw 345 | your own error, 346 | 347 | ----------- 348 | wisp> (defun intinc (n) 349 | (if (not (intp n)) 350 | (throw 'not-an-integer n) 351 | (+ 1 n))) 352 | (lambda (n) (if (not (intp n)) (throw (quote not-an-integer) n) (+ 1 n))) 353 | wisp> (intinc 10) 354 | 11 355 | wisp> (intinc 'a) 356 | Wisp error: (not-an-integer . a) 357 | wisp> 358 | ----------- 359 | 360 | This can be caught with +catch+, indicating the object you want to 361 | catch. Catch will return the attached object. The objects must be the 362 | same lisp object, so it would be wise to use only symbols for this. 363 | 364 | ----------- 365 | wisp> (catch 'not-an-integer (intinc 'a)) 366 | a 367 | ----------- 368 | 369 | The error catching and throwing the facilities will be improved, but 370 | will still rely on this basic principle. 371 | 372 | Functions and Macros 373 | -------------------- 374 | 375 | General purpose 376 | ~~~~~~~~~~~~~~~ 377 | 378 | Special form: +(quote _object_)+:: 379 | 380 | Returns _object_ unevaluated. 381 | 382 | Special form: +(and _conditions..._)+:: 383 | Special form: +(or _conditions..._)+:: 384 | 385 | These are your basic +and+ and +or+ special forms. They evaluate their 386 | conditions only as far as they need to. 387 | 388 | C function: +(not _object_)+:: 389 | 390 | Inverts the condition value of _object_. 391 | 392 | Special form: +(lambda _args_ _body..._)+:: 393 | 394 | Creates and returns an anonymous function. 395 | 396 | Special form: +(defun _name_ _args_ _body..._)+:: 397 | 398 | Defines and new function with name _name_. 399 | 400 | Special form: +(defmacro _name_ _args_ _body..._)+:: 401 | 402 | Defines a new macro with name _name_. 403 | 404 | C function: +(car _list_)+:: 405 | C function: +(cdr _list_)+:: 406 | 407 | Returns car and cdr components of cons cell, respectively. All 408 | combinations of +c_XXX_r+ are defined up to three center characters as 409 | well. So is +first+, +second+, etc. up to +tenth+. 410 | 411 | C function: +(list _objects_)+:: 412 | 413 | Returns arguments as a list. 414 | 415 | Special form: +(if _conditional_ _true-sexp_ _ false-body..._)+:: 416 | 417 | Special form: +(progn _body..._)+:: 418 | 419 | Executes body, returning final value. 420 | 421 | Special form: +(let _vars_ _body..._)+:: 422 | 423 | Binds variables and executes _body_. Like any other lisp. 424 | 425 | Special form: +(while _condition_ _body..._)+:: 426 | 427 | Continually execute body while _condition_ is true. 428 | 429 | C function: +(eval _object_)+:: 430 | 431 | Evaluate _object_. 432 | 433 | C function: +(print _object_)+:: 434 | 435 | Print object to standard output in parse-able form. 436 | 437 | C function: +(cons _car _cdr_)+:: 438 | 439 | Construct a new cons cell. 440 | 441 | Symbols 442 | ~~~~~~~ 443 | 444 | C function: +(set _symbol_ _object_)+:: 445 | 446 | Set value of _symbol_ to _object_. Notice this is not a macro, so you 447 | will likely want to quote the symbol. See +setq+. 448 | 449 | Macro: +(setq _symbol_ _object_)+:: 450 | 451 | Like set, but the symbol is quoted for you. 452 | 453 | C function: +(value _symbol_)+:: 454 | 455 | Return the object stored in the symbol. 456 | 457 | C function: +(symbol-name _symbol_)+:: 458 | 459 | Return symbol name as a string. 460 | 461 | Strings 462 | ~~~~~~~ 463 | 464 | Function: +(concat _strings..._)+:: 465 | 466 | Concatenate _strings_ into a single string. 467 | 468 | Equality 469 | ~~~~~~~~ 470 | 471 | C function: +(eq _a_ _b_)+:: 472 | 473 | Return true if _a_ and _b_ are the exact same lisp object. 474 | 475 | C function: +(eql _a_ _b_)+:: 476 | 477 | Return true if _a_ and _b_ represent similar objects (i.e. strings 478 | storing the same content). Always returns false for lists. 479 | 480 | Function: +(equals _a_ _b_)+:: 481 | 482 | Return true if two lists have similar (+eql+) contents and structure. 483 | 484 | C function: +(hash _object_)+:: 485 | 486 | Return hash of given lisp object. Fits inside of an unsigned, 4-byte 487 | integer. 488 | 489 | Predicates 490 | ~~~~~~~~~~ 491 | 492 | C function: +(nullp _object_)+:: 493 | C function: +(funcp _object_)+:: 494 | C function: +(listp _object_)+:: 495 | C function: +(symbolp _object_)+:: 496 | C function: +(stringp _object_)+:: 497 | C function: +(numberp _object_)+:: 498 | C function: +(integerp _object_)+:: 499 | C function: +(floatp _object_)+:: 500 | C function: +(vectorp _object_)+:: 501 | 502 | Return true if _object_ is of the type matching the function name. 503 | 504 | Input / Output 505 | ~~~~~~~~~~~~~~ 506 | 507 | C function: +(load _string_)+:: 508 | 509 | Evaluate contents in file _str_. 510 | 511 | C function: +(eval-string _string_)+:: 512 | 513 | Evaluate contents of string. 514 | 515 | Error handling 516 | ~~~~~~~~~~~~~~ 517 | 518 | C function: +(throw _thrown_ _attach_)+:: 519 | 520 | Throw an object as an error, with attachment. 521 | 522 | Special form: +(catch _object_ _body..._)+:: 523 | 524 | Evaluate body, catching _object_ if it is thrown, returning _object_. 525 | 526 | Vectors 527 | ~~~~~~~ 528 | 529 | C function: +(vset _vector_ _index_ _object_)+:: 530 | 531 | Put _object_ in _vector_ at position _index_. 532 | 533 | C function: +(vget _vector_ _index_)+:: 534 | 535 | Get object in _vector_ at position _index_. 536 | 537 | C function: +(vlength _vector_)+:: 538 | 539 | Length of the vector. 540 | 541 | C function: +(make-vector _size_ _init_)+:: 542 | 543 | Create a new vector of size _size_ with all positions set to _init_. 544 | 545 | C function: +(vconcat _vector_ _vector_)+:: 546 | 547 | Concatenate two vectors, creating a new vector object. 548 | 549 | Internals 550 | ~~~~~~~~~ 551 | 552 | C function: +(refcount _object_)+:: 553 | 554 | Return number reference count of _object_. This number is meaningless 555 | for symbols. 556 | 557 | C function: +(eval-depth)+:: 558 | 559 | Return current evaluation depth. 560 | 561 | C function: +(max-eval-depth _&optional_ _new-depth_)+:: 562 | 563 | Return the maximum evaluation depth. If an argument is provided, set 564 | the maximum depth to the given value. 565 | 566 | Libraries 567 | --------- 568 | 569 | hash 570 | ~~~~ 571 | 572 | Provides hash table functions. 573 | 574 | memoize 575 | ~~~~~~~ 576 | 577 | Provides a +memoize+ function to install memoization wrappers on any 578 | function. 579 | 580 | sandbox 581 | ~~~~~~~ 582 | 583 | Undefines "dangerous" funtions so that untrusted code can safely be 584 | executed. 585 | 586 | Internals 587 | --------- 588 | 589 | Objects 590 | ~~~~~~~ 591 | 592 | The +object_t+ struct defined in +object.h+ is the outer struct for 593 | every lisp object. It has a +type+ field, which matches the +type_t+ 594 | enumeration (also defined there) indicating the object type, and a 595 | +void val+ pointer pointing to the object data itself, which may be 596 | another struct. 597 | 598 | All of the convenient object creation functions are also declared 599 | here, prefixed with +c_+. You should almost always use these to make 600 | objects. This will keep you from making reference counting mistakes. 601 | 602 | Symbols 603 | ~~~~~~~ 604 | 605 | All symbol objects are interned, so they act like singletons. A given 606 | symbol has only one instance of itself at any time. The +c_sym()+ 607 | function will enforce this. 608 | 609 | Accessing objects stored in symbols can be done with the SET and GET 610 | macros. 611 | 612 | The +nil+ and +t+ symbols are already created and are made available 613 | as the global variables +T+ and +NIL+. All object pointers, including 614 | those in cons cells, should initialize/default to +NIL+ rather than 615 | +NULL+. 616 | 617 | C Functions 618 | ~~~~~~~~~~~ 619 | 620 | C functions, called CFUNCs, are C functions that are meant to be 621 | exposed to lisp space. CFUNCs have the following declaration types, 622 | 623 | ---------- 624 | object_t *function (object_t *lst); 625 | ---------- 626 | 627 | They accept a single object as an argument and return a single 628 | argument. The single argument will be a cons cell object containing 629 | all your arguments as a list. For your convenience in accessing this 630 | structure there are a number of macros available, defined in the 631 | various header files: +CAR+, +CDR+, +OINT+, +OFLOAT+, +OSTR+. 632 | 633 | It is the responsibility of the CFUNC to make sure the 634 | number of arguments is correct. 635 | 636 | To get an idea of what a CFUNC should look like, take a Look at the 637 | existing functions in +lisp.c+. 638 | 639 | The functions +eval()+ and +eval_body()+ are available for further 640 | evaluation of objects. This is actually more useful in special forms 641 | than anything else. 642 | 643 | Once the function is defined, you can install it in +lisp_init()+ with 644 | the "simple set" macro, 645 | 646 | ----------------- 647 | SET (c_sym ("function"), c_cfunc (&function)); 648 | ----------------- 649 | 650 | Special Forms 651 | ~~~~~~~~~~~~~ 652 | 653 | Special forms are exactly the same as functions, except that their 654 | arguments arrive unevaluated and they are installed with 655 | +c_special()+. Lisp macros are to lisp functions as special forms are 656 | to CFUNCs. 657 | 658 | ----------------- 659 | SET (c_sym ("if"), c_cfunc (&lisp_if)); 660 | ----------------- 661 | 662 | Error handling 663 | ~~~~~~~~~~~~~~ 664 | 665 | A CFUNC must be prepared to deal with error exceptions. If there was 666 | an error when calling another CFUNC, such as +eval()+, it will return 667 | the error symbol, stored in +err_symbol+. Note, this isn't the same as 668 | the object being thrown, which is stored in +err_thrown+. If a CFUNC 669 | receives this, it must either catch it, or (more likely) immediately 670 | clean up (i.e. destroy objects) so it can return cleanly, passing the 671 | error symbol along. 672 | 673 | The +CHECK+ macro is available for when no cleanup is needed. 674 | 675 | To throw an error, set +err_thrown+ to the object you want to throw, 676 | and set +err_attach+ to it's attachment; generally the thrown object 677 | will be a symbol. The +THROW+ macro makes this easy. 678 | 679 | The +top_eval()+ function is the final error handler and will catch 680 | any errors in order to display it. It should only be called by the 681 | originating evaluator, such as the parser. 682 | 683 | Reference Counting 684 | ~~~~~~~~~~~~~~~~~~ 685 | 686 | Working with reference counting can be tricky, but once you get the 687 | mental model of what's going on it won't be too bad. Getting this 688 | wrong will lead to either memory leaks or segmentation faults. Either 689 | one is a pain to track down, so don't mess it up. 690 | 691 | Calling a function and receiving an object is considered an act of 692 | creation, no matter what. This object _must_ either be destroyed with 693 | +obj_destroy()+ or passed _directly_ as a return value. If passed, a 694 | CFUNC doesn't need to increase the counter, as both a decrement are 695 | increment are needed, which cancels out. 696 | 697 | Object returners are responsible for increasing the reference 698 | counter. The +UPREF+ macro is provided for this. If a CFUNC references 699 | into an s-expression to return it, the counter increase is required. 700 | 701 | Be mindful of the order in which you increment and decrement a 702 | counter. If you decrement the root first, then increment a child 703 | object in that root, the child object may not exist anymore. 704 | 705 | When just passing an object to a function, a CFUNC doesn't need to 706 | increment the counter. That function is responsible for the new 707 | references it makes. There is one exception to this: 708 | +c_cons()+. Objects passed to +c_cons()+ need to be incremented, 709 | unless they come directly from another function. 710 | 711 | The reason for this is because this is a common thing to do, 712 | 713 | ----------- 714 | c_cons (c_int (100), NIL); 715 | ----------- 716 | 717 | The +c_int()+ function already incremented the counter, so it need not 718 | be incremented again. 719 | 720 | If you store a reference to an argument anywhere, you need to increase 721 | the reference counter for that object. The +SET+ macro does this for 722 | you (+SSET+ does not). 723 | 724 | Because all symbol are interned, they are never destroyed, so if you 725 | know you are dealing with symbols you don't need to worry about 726 | reference counts. This applies to the special +NIL+ and +T+ symbols 727 | too. This is perfectly acceptable, 728 | 729 | ---------- 730 | return NIL; 731 | ---------- 732 | 733 | Contributing 734 | ------------ 735 | 736 | All functions and macros should be in lisp form when possible. This 737 | makes them much easier and safer to edit. It also makes them more 738 | accessible and transparent at run time. 739 | 740 | I've put some stuff I want to get done in the TODO list. 741 | 742 | When I remember to, I run GNU indent on all the code with just the 743 | -npsl flag. If you do this, your code will match the style. Compiled 744 | code should give no warnings or errors and should conform to C99. 745 | --------------------------------------------------------------------------------