zenlisp-2013.11.22/0000775000175000017500000000000012267235063012521 5ustar barakbarakzenlisp-2013.11.22/base.l0000644000175000017500000000747111065365170013615 0ustar barakbarak; zenlisp base functions ; By Nils M Holm, 2007, 2008 ; Feel free to copy, share, and modify this code. ; See the file LICENSE for details. (define base :t) (define (null x) (eq x ())) (define (id x) x) (define (list . x) x) (define (not a) (eq a :f)) (define (neq x y) (eq (eq x y) :f)) (define (caaaar x) (car (car (car (car x))))) (define (caaadr x) (car (car (car (cdr x))))) (define (caadar x) (car (car (cdr (car x))))) (define (caaddr x) (car (car (cdr (cdr x))))) (define (cadaar x) (car (cdr (car (car x))))) (define (cadadr x) (car (cdr (car (cdr x))))) (define (caddar x) (car (cdr (cdr (car x))))) (define (cadddr x) (car (cdr (cdr (cdr x))))) (define (cdaaar x) (cdr (car (car (car x))))) (define (cdaadr x) (cdr (car (car (cdr x))))) (define (cdadar x) (cdr (car (cdr (car x))))) (define (cdaddr x) (cdr (car (cdr (cdr x))))) (define (cddaar x) (cdr (cdr (car (car x))))) (define (cddadr x) (cdr (cdr (car (cdr x))))) (define (cdddar x) (cdr (cdr (cdr (car x))))) (define (cddddr x) (cdr (cdr (cdr (cdr x))))) (define (caaar x) (car (car (car x)))) (define (caadr x) (car (car (cdr x)))) (define (cadar x) (car (cdr (car x)))) (define (caddr x) (car (cdr (cdr x)))) (define (cdaar x) (cdr (car (car x)))) (define (cdadr x) (cdr (car (cdr x)))) (define (cddar x) (cdr (cdr (car x)))) (define (cdddr x) (cdr (cdr (cdr x)))) (define (caar x) (car (car x))) (define (cadr x) (car (cdr x))) (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) (define (fold f x a) (letrec ((fold2 (lambda (a res) (cond ((null a) res) (t (fold2 (cdr a) (f res (car a)))))))) (fold2 a x))) (define (fold-r f x a) (letrec ((fold2 (lambda (a) (cond ((null a) x) (t (f (car a) (fold2 (cdr a)))))))) (fold2 a))) (define (reverse a) (letrec ((reverse2 (lambda (a b) (cond ((null a) b) (t (reverse2 (cdr a) (cons (car a) b))))))) (reverse2 a ()))) (define (append . a) (letrec ((append2 (lambda (a b) (cond ((null a) b) (t (append2 (cdr a) (cons (car a) b))))))) (fold (lambda (a b) (append2 (reverse a) b)) () a))) (define (equal a b) (cond ((eq a b) :t) ((or (atom a) (atom b)) (eq a b)) (t (and (equal (car a) (car b)) (equal (cdr a) (cdr b)))))) (define (assoc x a) (cond ((null a) :f) ((equal (caar a) x) (car a)) (t (assoc x (cdr a))))) (define (assq x a) (cond ((null a) :f) ((eq (caar a) x) (car a)) (t (assq x (cdr a))))) (define (listp x) (or (null x) (and (not (atom x)) (listp (cdr x))))) (define (map f . a) (letrec ((map-car (lambda (f a r) (cond ((null a) (reverse r)) (t (map-car f (cdr a) (cons (f (car a)) r)))))) (car-of (lambda (a) (map-car car a ()))) (cdr-of (lambda (a) (map-car cdr a ()))) (any-null (lambda (a) (apply or (map-car null a ())))) (map2 (lambda (a b) (cond ((any-null a) (reverse b)) (t (map2 (cdr-of a) (cons (apply f (car-of a)) b))))))) (cond ((null a) (bottom '(too few arguments to map))) (t (map2 a ()))))) (define (member x a) (cond ((null a) :f) ((equal (car a) x) a) (t (member x (cdr a))))) (define (memq x a) (cond ((null a) :f) ((eq (car a) x) a) (t (memq x (cdr a))))) (define (require x) (letrec ((require2 (lambda (sym file) (cond ((defined sym) :f) (t (apply load (list file))))))) (let ((xx (explode x))) (cond ((eq (car xx) '~) (require2 (implode (cdr xx)) x)) (t (require2 x x)))))) zenlisp-2013.11.22/Changes0000644000175000017500000000656212243656564014032 0ustar barakbarak2013-11-22 Fixed image generation bug (infinite loop) on various systems. 2008-09-23 Fixed PREFIX and REGEX examples (src/compilers/). 2008-09-19 Removed annoying copyright messages. Added "license". 2008-09-13 Completed code of LAMBDA-RENAME (src/compilers/lv-rename.l). 2008-08-27 Applied more cosmetical changes. 2008-08-26 Applied some cosmetical changes. 2008-05-03 Removed PACKAGE and EXPORT (maintain identity of symbols!). 2008-05-03 Prefixed internal definitions with %. 2008-05-03 Protected internal definitions using LET. 2008-04-08 Fix: detect improper lists in function applications. 2008-02-02 Fix: missing initialization of Batch variable. 2008-01-31 Caught non-atoms in PACKAGE. 2008-01-27 Optimized allocation in make_closure(). 2008-01-26 Removed TraceHandler (unused), more clean up. 2008-01-22 More code clean up. 2008-01-19 Code clean up. 2007-12-30 Made '{' character a separator. 2007-12-29 Made primitives and specials atomic in the sense of ATOM. 2007-12-27 Added support for ~ in REQUIRE. 2007-12-26 Changed (APPLY FN LIST) --> (APPLY FN [ARG...] LIST). 2007-12-15 Renamed true value to :T, made T refer to :T. 2007-12-15 Renamed = prefix in LOAD to ~, removed ~/ prefix. 2007-12-15 Removed READ, WRITE. 2007-12-14 Cleaned up zl.c. 2007-12-12 Added GENSYM primitive. 2007-12-12 Fixed N-EXPT (was slow due to wrong recursion). 2007-12-12 Code clean-up. 2007-12-11 Changed (REDUCE-R F A B) --> (FOLD-R F B A) 2007-12-11 Changed (REDUCE F A B) --> (FOLD F B A) 2007-12-11 Applied more micro optimizations. 2007-12-10 Merged alisp.c, alisp.h, and shell.c. 2007-12-09 Applied some micro optimizations. 2007-12-08 Changed rational format from (/ #n #d) to #n/d. 2007-12-08 Forked zenlisp. 2006-09-17 Fixed false positive in test suite. 2006-09-13 Fixed tail recursion while passing closures. 2006-09-12 Added GENERATOR example (src/misc/gener.l) 2006-09-12 Updated reference manual (alisp.txt) and man page (alisp.7). 2006-09-11 Fixed natural = operator (did not normalize arguments). 2006-09-09 Made {...} unREADable. 2006-09-09 Changed representation of unreadable objects to {...}. 2006-09-09 Fixed xread(): no longer returns EOT on bad pairs. 2006-09-08 Fixed ()=>() whith VERIFY-ARROWS enabled. 2006-09-07 Added -L option (print license). 2006-09-07 Renamed examples/ to src/. 2006-09-07 ALISP_RELEASE now reflects all changes (not just alisp.c). 2006-09-04 Added a more general predicate iterator (iter.l). 2006-08-27 Updated LVRENAME and UNLET programs (src/misc). 2006-08-22 Made NUMBER-P catch dotted lists. 2006-08-22 Made INTEGER reduce rationals when RMATH is loaded. 2006-08-17 Added REDUCE-R function (right-associative REDUCE). 2006-08-15 Closures no longer capture quoted symbols (see collect()). 2006-07-16 Added ArrowLISP Micro KANREN and ZEBRA example. 2006-07-13 Made ALISP restore default package when aborting evaluation. 2006-07-01 Fixed CopyBindings() (did not copy all packages). 2006-06-30 Changed representation of false value from () to :F. 2006-06-30 Made :T an alias of T. 2006-06-27 Allowed (EXPLODE ()) => () and (IMPLODE ()) => (). 2006-06-26 Made WRITE print a leading quote. 2006-06-16 Added QUIT primitive. 2006-06-15 Improved some error messages. 2006-06-14 Added -g (track GC) command line option. 2006-06-08 Made application of CAR and CDR to internals illegal. 2006-06-08 GC-Protected Error Context (only in case of an error). 2006-06-08 GC-Protected expressions during EVAL. Oops. zenlisp-2013.11.22/_checksums0000644000175000017500000000714512243657044014576 0ustar barakbarak503C6AAADF3FC158 0007 0172 ./Changes B46F50345DBDF7FF 0002 01E5 ./LICENSE D15808654DCEC078 0005 01A0 ./Makefile 976D84FD148A0284 0003 01E6 ./Makefile.DIST C6B97540D48AEEAA 0003 0034 ./README 00000000000414A0 0001 000C ./Todo 245D23F5080D69E1 0008 0139 ./base.l 0000000001426688 0001 0012 ./foo.l 12A65EAA6D08EDAA 000B 00D4 ./imath.l 63E4C2714943F0FF 0002 00F7 ./iter.l 801BF3F8F0800ABE 0016 0111 ./nmath.l 3C0DC3788FBEBC17 000E 0154 ./rmath.l 62D1CA3ABC0067ED 000A 0138 ./src/amk/amk.l C4BE98C31F5ACAA3 0004 00CA ./src/amk/zebra.l 906D42F85B8B9537 0008 0149 ./src/compilers/infix.l 8C8213A830863A47 0005 006E ./src/compilers/lv-rename.l 1028213FF4952388 0008 0187 ./src/compilers/prefix.l 785E77D38F6E15CF 0004 0044 ./src/compilers/prolog-db.l A3E3AC1A9B345838 0006 00FC ./src/compilers/prolog.l 3AB364FF957E79B2 000C 00D6 ./src/compilers/regex.l 5B34849F1D40337F 0002 0114 ./src/compilers/unlet.l D450C5CFF77F87B5 0012 0150 ./src/compilers/zeval.l BA4880FD61B5A804 0001 0140 ./src/lists/count.l 5B56A2B99DDE34FE 0001 0172 ./src/lists/depth.l 95DF63CEE3293CB0 0002 0025 ./src/lists/filter.l 76945F6BF0B99A77 0001 0174 ./src/lists/flatten.l C68F0C402D8D7288 0002 0082 ./src/lists/fold-left.l 2D07D0FFE2DFB361 0002 00D3 ./src/lists/fold-right.l 788FB31F67032056 0001 0168 ./src/lists/headp.l F32D1954FE267F22 0001 00CD ./src/lists/last.l 3233477D6319291A 0001 0154 ./src/lists/nth.l C9C7EC7CE8665DDF 0001 00F4 ./src/lists/pair.l EBBBB180E5676EF9 0002 008B ./src/lists/partition.l 5C9014DDA24A519D 0001 0103 ./src/lists/remove.l 5E0EE68A9ADC09D0 0001 0171 ./src/lists/replace.l 8F1E773BDF2D41F3 0002 002D ./src/lists/substitute.l F07E5B2C7E4269F7 0001 01AD ./src/lists/tailp.l 766E995A92367A17 0001 012B ./src/logic/any.l EB82DF9F901A8402 0002 01E0 ./src/logic/combine.l 43108836C3234AD0 0001 0149 ./src/logic/every.l AB7FD3768F8062A2 0002 004A ./src/logic/exists.l D601FC6DAB1AF376 0002 009A ./src/logic/for-all.l E571B084A93B605C 0003 01AD ./src/logic/permute.l BEB9F38FAEE4B1B8 0001 014F ./src/logic/some.l 1D0DBC9A6EE0A62A 0001 019A ./src/math/factorial.l 11A2B35B2935AB1D 0003 01C9 ./src/math/factors.l 5F167EE2F959C983 0002 0001 ./src/math/hyper.l 01CDD5E53A8D0127 0001 016B ./src/math/iota.l 851151D480565C73 0002 0177 ./src/math/make-partitions.l 80E9535EFF6CDAD3 0001 01F1 ./src/math/product.l 85DE30048DD9DA7E 0002 0034 ./src/math/sum.l 4BF853E20BEF17CD 0001 00EB ./src/math/transpose.l 0BFA033896E271D3 0001 015D ./src/mexprc/m_append.l 3555CFE8607919DA 0001 0102 ./src/mexprc/m_fac.l 90801306A17F6EAC 0001 01BE ./src/mexprc/m_hanoi.l 0591AA8CB3BC096C 0002 01F1 ./src/mexprc/m_queens.l 7E42E46210FC9EB0 0030 000A ./src/mexprc/mexprc.l 72B498FA43EBE13A 0005 00D7 ./src/misc/bottles.l 915966AC702A0259 0001 01E1 ./src/misc/gener.l 5BDCB4390ADD4174 0001 01D8 ./src/misc/hanoi.l A1B13690F40340DB 0001 00A8 ./src/misc/o.l 560042B5EF2AC19C 0005 0127 ./src/misc/queens.l 07C6B75F64D573AE 0001 00C6 ./src/misc/quine.l D6078244CCD28535 0009 0081 ./src/misc/records.l A00B8929FD13FDB0 0003 00EA ./src/misc/streams.l C0C6393C168443E6 0002 001E ./src/sets/intersection.l 7E05EF8E83395B7C 0001 01EB ./src/sets/listtoset.l C43932A0A8EA042D 0001 0107 ./src/sets/union.l B228A4C489521CA3 0002 00F1 ./src/sort/bubblesort.l 89792D3F52095136 0001 01B0 ./src/sort/insert.l D640DE1EE547C8ED 0001 01A3 ./src/sort/isort.l 6F9E92F43B97D900 0003 00B3 ./src/sort/mergesort.l 36E274B9D44C7E47 0001 01CF ./src/sort/orderedp.l 79E9895E3A7AABD2 0002 0073 ./src/sort/quicksort.l B32129E3B9BB8B67 0002 01AE ./src/sort/unsort.l 0E7F63A43888C10D 0029 0094 ./test.OK 89F39B73C3B54021 0030 00DF ./test.l C7AA795394BE84E7 0036 016C ./zenlisp.txt 09D76E33DC9CF540 0005 010E ./zl.1 EE47E15A6D272FF6 0073 0185 ./zl.c zenlisp-2013.11.22/foo.l0000644000175000017500000000002210432312610013433 0ustar barakbarak(define foo 'bar) zenlisp-2013.11.22/imath.l0000644000175000017500000001232411064650200013764 0ustar barakbarak; zenlisp integer math functions ; By Nils M Holm, 2007, 2008 ; Feel free to copy, share, and modify this code. ; See the file LICENSE for details. ; would use REQUIRE, but REQUIRE is in BASE (cond ((defined 'base) :f) (t (load base))) (define imath :t) (require 'nmath) (define (integer-p a) (and (not (atom a)) (or (natural-p a) (and (memq (car a) '#+-) (natural-p (cdr a)))))) (define (i-integer a) (cond ((eq (car a) '+) (cdr a)) ((eq (car a) '-) a) ((digitp (car a)) a) (t (bottom (list 'i-integer a))))) (define (i-natural a) (cond ((eq (car a) '+) (cdr a)) ((digitp (car a)) a) (t (bottom (list 'i-natural a))))) (define (i-normalize x) (cond ((eq (car x) '+) (n-normalize (cdr x))) ((eq (car x) '-) (let ((d (n-normalize (cdr x)))) (cond ((n-zero d) d) (t (cons '- d))))) (t (n-normalize x)))) (define (i-negative x) (eq (car x) '-)) (define (i-abs x) (cond ((i-negative x) (cdr x)) ((eq (car x) '+) (cdr x)) (t x))) (define (i-zero x) (n-zero (i-abs x))) (define (i-one x) (and (n-one (i-abs x)) (neq (car x) '-))) (define (i-negate x) (cond ((n-zero (i-abs x)) x) ((eq (car x) '-) (cdr x)) ((eq (car x) '+) (cons '- (cdr x))) (t (cons '- x)))) (define (i+ a b) (cond ((and (not (i-negative a)) (not (i-negative b))) (n+ (i-abs a) (i-abs b))) ((and (not (i-negative a)) (i-negative b)) (cond ((n> (i-abs a) (i-abs b)) (n- (natural a) (i-abs b))) (t (i-negate (n- (i-abs b) (natural a)))))) ((and (i-negative a) (not (i-negative b))) (cond ((n> (i-abs a) (i-abs b)) (i-negate (n- (i-abs a) (natural b)))) (t (n- (natural b) (i-abs a))))) (t (i-negate (n+ (i-abs a) (i-abs b)))))) (define (i- a b) (cond ((i-negative b) (i+ a (i-abs b))) ((i-negative a) (i+ a (i-negate b))) ((n< (i-abs a) (i-abs b)) (i-negate (n- (i-abs b) (i-abs a)))) (t (n- (i-abs a) (i-abs b))))) (define (i< a b) (cond ((i-negative a) (cond ((not (i-negative b)) :t) (t (n< (i-abs b) (i-abs a))))) ((i-negative b) :f) (t (n< (i-abs a) (i-abs b))))) (define (i> a b) (i< b a)) (define (i<= a b) (eq (i> a b) :f)) (define (i>= a b) (eq (i< a b) :f)) (define (i= a b) (equal (i-normalize a) (i-normalize b))) (define (i* a b) (cond ((zero a) '#0) ((eq (i-negative a) (i-negative b)) (n* (i-abs a) (i-abs b))) (t (i-negate (n* (i-abs a) (i-abs b)))))) (define (i-divide a b) (letrec ((sign (lambda (x) (cond ((eq (i-negative a) (i-negative b)) x) (t (cons '- x))))) (rsign (lambda (x) (cond ((i-negative a) (cons '- x)) (t x)))) (idiv (lambda (a b) (cond ((n-zero b) (bottom '(divide by zero))) ((n< (i-abs a) (i-abs b)) (list '#0 (rsign (i-abs a)))) (t (let ((q (n-divide (i-abs a) (i-abs b)))) (list (sign (car q)) (rsign (cadr q))))))))) (idiv (i-integer a) (i-integer b)))) (define (i-quotient a b) (car (i-divide a b))) (define (i-remainder a b) (cadr (i-divide a b))) (define (modulo a b) (let ((rem (i-remainder a b))) (cond ((i-zero rem) '#0) ((eq (i-negative a) (i-negative b)) rem) (t (i+ b rem))))) (define (i-expt x y) (letrec ((i-expt (lambda (x y) (cond ((or (not (i-negative x)) (even y)) (n-expt (i-abs x) y)) (t (i-negate (n-expt (i-abs x) y))))))) (i-expt (i-integer x) (natural y)))) (define (i-max . a) (apply limit i> a)) (define (i-min . a) (apply limit i< a)) (define (i-sqrt x) (cond ((i-negative x) (bottom (list 'i-sqrt x))) (t (n-sqrt x)))) (define (i-gcd a b) (n-gcd (i-abs a) (i-abs b))) (define (i-lcm a b) (n-lcm (i-abs a) (i-abs b))) (require 'iter) (define integer i-integer) (define * (arithmetic-iterator integer i* '#1)) (define + (arithmetic-iterator integer i+ '#0)) (define (- . x) (cond ((null x) (bottom '(too few arguments to integer -))) ((eq (cdr x) ()) (i-negate (car x))) (t (fold (lambda (a b) (i- (integer a) (integer b))) (car x) (cdr x))))) (define < (predicate-iterator integer i<)) (define <= (predicate-iterator integer i<=)) (define = (predicate-iterator integer i=)) (define > (predicate-iterator integer i>)) (define >= (predicate-iterator integer i>=)) (define abs i-abs) (define divide i-divide) (define expt i-expt) (define gcd (arithmetic-iterator integer i-gcd '#0)) (define lcm (arithmetic-iterator integer i-lcm '#1)) (define max i-max) (define min i-min) (define natural i-natural) (define negate i-negate) (define negative i-negative) (define number-p integer-p) (define one i-one) (define quotient i-quotient) (define remainder i-remainder) (define sqrt i-sqrt) (define zero i-zero) zenlisp-2013.11.22/iter.l0000644000175000017500000000136711065366270013646 0ustar barakbarak; zenlisp iterators ; By Nils M Holm, 2007, 2008 ; Feel free to copy, share, and modify this code. ; See the file LICENSE for details. (define iter :t) (define (arithmetic-iterator conv fn neutral) (lambda x (cond ((null x) neutral) (t (fold (lambda (a b) (fn (conv a) (conv b))) (car x) (cdr x)))))) (define (predicate-iterator conv fn) (let ((:fail (cons ':fail ()))) (let ((comp (lambda (a b) (cond ((eq a :fail) :fail) ((fn (conv a) (conv b)) b) (t :fail))))) (lambda (first . rest) (cond ((null rest) (bottom '(too few arguments))) (t (neq (fold comp first rest) :fail))))))) zenlisp-2013.11.22/LICENSE0000644000175000017500000000174512243656256013540 0ustar barakbarak zenlisp -- An interpreter for symbolic LISP By Nils M Holm, 2007, 2008, 2013 Don't worry, be happy. Frankly, life's too short to deal with legal stuff, so * do what ever you want with my code; * if the code doesn't work, don't blame me. Disclaimer THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. zenlisp-2013.11.22/Makefile0000644000175000017500000000274612243670070014163 0ustar barakbarak# zenlisp Makefile # By Nils M Holm, 2007, 2008 # See the file LICENSE for conditions of use. V= 2 PREFIX?=/usr/local BINOWN?=bin BINGRP?=bin BINDIR= $(PREFIX)/bin SHRDIR= $(PREFIX)/share/zenlisp MANDIR= $(PREFIX)/man/man1 DOCDIR= $(PREFIX)/share/doc/zenlisp IMAGE= $(PREFIX)/share/zenlisp/zenlisp LIBS= base.l imath.l iter.l nmath.l rmath.l CFLAGS= -O -DDEFAULT_IMAGE="\"$(IMAGE)\"" LINTFLAGS= -Wall -ansi -pedantic -Wmissing-prototypes -DLINT all: zl zenlisp zl: zl.c $(CC) $(CFLAGS) -o zl zl.c lint: $(CC) $(CFLAGS) $(LINTFLAGS) -o zl zl.c zenlisp: zl base.l echo '(load base) (dump-image zenlisp)' | ./zl -bi -n 12K test: zl rm -f delete-me ZENSRC=. ./zl -i (lambda (a b) (%d< b a))) (lt (lambda (a b r) (cond ((and (null a) (null b)) r) ((null a) :t) ((null b) :f) (t (lt (cdr a) (cdr b) (cond ((%d< (car a) (car b)) :t) ((d> (car a) (car b)) :f) (t r)))))))) (lt (reverse a) (reverse b) :f))))) (define (n> a b) (n< b a)) (define (n<= a b) (eq (n> a b) :f)) (define (n>= a b) (eq (n< a b) :f)) (define (n= a b) (equal (n-normalize a) (n-normalize b))) (define n+ (let () (lambda (a b) (letrec ((add (lambda (a b c r) (cond ((null a) (cond ((null b) (cond ((eq c 0) r) ; no carry (t (cons 1 r)))) (t (let ((sum (%d+ 0 (car b) c))) (add () (cdr b) (cdr sum) (cons (car sum) r)))))) ((null b) (let ((sum (%d+ (car a) 0 c))) (add (cdr a) () (cdr sum) (cons (car sum) r)))) (t (let ((sum (%d+ (car a) (car b) c))) (add (cdr a) (cdr b) (cdr sum) (cons (car sum) r)))))))) (add (reverse a) (reverse b) 0 ()))))) (define n- (let () (lambda (a b) (letrec ((diff (lambda (a b c r) (cond ((null a) (cond ((null b) (cond ((eq c 0) r) (t (bottom '(negative difference))))) (t (bottom '(negative difference))))) ((null b) (cond ((eq c 0) (append (reverse a) r)) (t (diff a '(1) 0 r)))) (t (let ((delta (%d- (car a) (car b) c))) (diff (cdr a) (cdr b) (cdr delta) (cons (car delta) r)))))))) (n-normalize (diff (reverse a) (reverse b) 0 ())))))) (define (n-zero x) (and (eq (car x) 0) (null (cdr x)))) (define (n-one x) (and (eq (car x) 1) (null (cdr x)))) (define (n* a b) (letrec ((*10 (lambda (x) (append x '#0))) (add-n-times (lambda (a b r) (cond ((n-zero (list b)) r) (t (add-n-times a (pred b) (n+ a r)))))) (times (lambda (a b r) (cond ((null b) r) (t (times (*10 a) (cdr b) (add-n-times a (car b) r))))))) (cond ((n-zero a) '#0) (t (times a (reverse b) '#0))))) (define (n-divide a b) (letrec ; Equalize the divisor B by shifting it to the left ; (multiplying it by 10) until it has the same number ; of digits as the dividend A. ; Return: (new divisor . base 1 shift count) ((eql (lambda (a b r s) (cond ((null a) (cons (reverse r) s)) ((null b) (eql (cdr a) () (cons 0 r) (cons 'i s))) (t (eql (cdr a) (cdr b) (cons (car b) r) s))))) ; Divide with quotient < 10 ; Return (A/B*B . A/B) (div10 (lambda (a b r) (cond ((n< (car r) a) (div10 a b (cons (n+ (car r) b) (n+ (cdr r) '#1)))) ((equal (car r) a) r) (t (cons (n- (car r) b) (n- (cdr r) '#1)))))) ; X / 10 (d10 (lambda (x) (reverse (cdr (reverse x))))) (div (lambda (a b r) (cond ((null (cdr b)) (list (n-normalize r) a)) (t (let ((quot (div10 a (car b) (cons '#0 '#0)))) (div (n- a (car quot)) (cons (d10 (car b)) (cddr b)) (append r (cdr quot))))))))) (cond ((n-zero b) (bottom 'divide-by-zero)) ((n< a b) (list '#0 a)) (t (div a (eql a b () '#i) '#0))))) (define (n-quotient a b) (car (n-divide a b))) (define (n-remainder a b) (cadr (n-divide a b))) (define (even x) (and (memq (car (reverse x)) '#02468) :t)) (define (odd x) (eq (even x) :f)) (define (n-expt x y) (letrec ((square (lambda (x) (n* x x))) (n-expt1 (lambda (y) (cond ((n-zero y) '#1) ((even y) (square (n-expt1 (n-quotient y '#2)))) (t (n* x (square (n-expt1 (n-quotient y '#2))))))))) (n-expt1 (n-natural y)))) (define (n-sqrt square) (letrec ((sqr (lambda (x last) (cond ((equal last x) x) ((equal last (n+ x '#1)) (cond ((n> (n* x x) square) (n- x '#1)) (t x))) (t (sqr (n-quotient (n+ x (n-quotient square x)) '#2) x)))))) (sqr square '#0))) (define (length x) (letrec ((len (lambda (x r) (cond ((null x) r) (t (len (cdr x) (n+ r '#1))))))) (len x '#0))) (define (n-gcd a b) (cond ((n-zero b) a) ((n-zero a) b) ((n< a b) (n-gcd a (n-remainder b a))) (t (n-gcd b (n-remainder a b))))) (define (n-lcm a b) (let ((cd (n-gcd a b))) (n* cd (n* (n-quotient a cd) (n-quotient b cd))))) (define (limit op a . b) (letrec ((lim (lambda (a) (cond ((null (cdr a)) (car a)) ((op (car a) (cadr a)) (lim (cons (car a) (cddr a)))) (t (lim (cdr a))))))) (lim (cons a b)))) (define (n-max . a) (apply limit n> a)) (define (n-min . a) (apply limit n< a)) (require 'iter) (define natural n-natural) (define * (arithmetic-iterator n-natural n* '#1)) (define + (arithmetic-iterator n-natural n+ '#0)) (define (- . x) (cond ((or (null x) (null (cdr x))) (bottom '(too few arguments to n-natural -))) (t (fold (lambda (a b) (n- (n-natural a) (n-natural b))) (car x) (cdr x))))) (define < (predicate-iterator natural n<)) (define <= (predicate-iterator natural n<=)) (define = (predicate-iterator natural n=)) (define > (predicate-iterator natural n>)) (define >= (predicate-iterator natural n>=)) (define divide n-divide) (define expt n-expt) (define gcd (arithmetic-iterator natural n-gcd '#0)) (define lcm (arithmetic-iterator natural n-lcm '#1)) (define max n-max) (define min n-min) (define number-p natural-p) (define one n-one) (define quotient n-quotient) (define remainder n-remainder) (define sqrt n-sqrt) (define zero n-zero) zenlisp-2013.11.22/README0000644000175000017500000000206412243656230013376 0ustar barakbarak z e n l i s p An interpreter for symbolic LISP By Nils M Holm, 2008, 2013 Feel free to copy, share, and modify this program. See the file LICENSE for details. What is zenlisp? Zenlisp is an interpreter for a purely symbolic, side effect-free, lexically scoped dialect of LISP. It may be considered an implementation of pure LISP plus global definitions. Zenlisp is derived from ArrowLISP. Installation The interpreter is written in ANSI C (C89) and zenlisp. It should compile without any modifications on a variety of systems including *BSD, Linux, Plan 9 (using APE), and W*ndows via MinGW or Cygwin. On a typical post-1990 Unix system typing make su make install exit should work fine. Getting Started After installing zenlisp, type "zl" to start the interpreter. Typing "man 1 zl" will produce the zl(1) man page. The Reference Manual can be found in the file /usr/local/share/doc/zenlisp/zenlisp.txt (unless you are using a different PREFIX). Feedback Please send your feedback to Nils M Holm Thanks! zenlisp-2013.11.22/rmath.l0000644000175000017500000001552411066111754014012 0ustar barakbarak; zenlisp rational math functions ; By Nils M Holm, 2007, 2008 ; Feel free to copy, share, and modify this code. ; See the file LICENSE for details. ; would use REQUIRE, but REQUIRE is in BASE (cond ((defined 'base) :f) (t (load base))) (define rmath :t) (require 'imath) (define (numerator x) (reverse (cdr (memq '/ (reverse x))))) (define (denominator x) (cdr (memq '/ x))) (define (rational-p x) (and (listp x) (memq '/ x) (integer-p (numerator x)) (integer-p (denominator x)))) (define (r-number-p x) (or (integer-p x) (rational-p x))) (define (make-rational num den) (append num '#/ den)) (define (rational x) (cond ((rational-p x) x) (t (make-rational x '#1)))) (define (r-zero x) (cond ((rational-p x) (r= x '#0)) (t (i-zero x)))) (define (r-one x) (cond ((rational-p x) (r= x '#1)) (t (i-one x)))) (define (%least-terms x) (let ((cd (gcd (numerator x) (denominator x)))) (cond ((r-one cd) x) (t (make-rational (quotient (numerator x) cd) (quotient (denominator x) cd)))))) (define (%decay x) (cond ((r-one (denominator x)) (numerator x)) (t x))) (define r-normalize (let () (lambda (x) (letrec ((norm-sign (lambda (x) (let ((num (numerator x)) (den (denominator x))) (let ((pos (eq (i-negative num) (i-negative den)))) (make-rational (cond (pos (i-abs num)) (t (cons '- (i-abs num)))) (i-abs den))))))) (cond ((rational-p x) (%decay (%least-terms (norm-sign x)))) (t (i-normalize x))))))) (define (r-integer x) (let ((xlt (+ '#0 x))) (cond ((rational-p xlt) (bottom (list 'r-integer x))) (t xlt)))) (define (r-natural x) (i-natural (r-integer x))) (define (r-abs x) (cond ((rational-p x) (make-rational (i-abs (numerator x)) (i-abs (denominator x)))) (t (i-abs x)))) (define (%equalize a b) (let ((num-a (numerator a)) (num-b (numerator b)) (den-a (denominator a)) (den-b (denominator b))) (let ((cd (gcd den-a den-b))) (cond ((r-one cd) (list (make-rational (i* num-a den-b) (i* den-a den-b)) (make-rational (i* num-b den-a) (i* den-b den-a)))) (t (list (make-rational (quotient (i* num-a den-b) cd) (quotient (i* den-a den-b) cd)) (make-rational (quotient (i* num-b den-a) cd) (quotient (i* den-b den-a) cd)))))))) (define r+ (let () (lambda (a b) (let ((factors (%equalize (rational a) (rational b))) (radd (lambda (a b) (r-normalize (make-rational (i+ (numerator a) (numerator b)) (denominator a)))))) (radd (car factors) (cadr factors)))))) (define r- (let () (lambda (a b) (let ((factors (%equalize (rational a) (rational b))) (rsub (lambda (a b) (r-normalize (make-rational (i- (numerator a) (numerator b)) (denominator a)))))) (rsub (car factors) (cadr factors)))))) (define (r* a b) (let ((rmul (lambda (a b) (r-normalize (make-rational (i* (numerator a) (numerator b)) (i* (denominator a) (denominator b))))))) (rmul (rational a) (rational b)))) (define (r/ a b) (let ((rdiv (lambda (a b) (r-normalize (make-rational (i* (numerator a) (denominator b)) (i* (denominator a) (numerator b))))))) (cond ((r-zero b) (bottom (list 'r/ a b))) (t (rdiv (rational a) (rational b)))))) (define r< (let () (lambda (a b) (let ((factors (%equalize (rational a) (rational b)))) (i< (numerator (car factors)) (numerator (cadr factors))))))) (define (r> a b) (r< b a)) (define (r<= a b) (eq (r> a b) :f)) (define (r>= a b) (eq (r< a b) :f)) (define r= (let () (lambda (a b) (cond ((or (rational-p a) (rational-p b)) (equal (%least-terms (rational a)) (%least-terms (rational b)))) (t (i= a b)))))) (define (r-expt x y) (letrec ((rx (cond ((i-negative (r-integer y)) (r/ '#1 (rational x))) (t (rational x)))) (square (lambda (x) (r* x x))) (exp (lambda (x y) (cond ((r-zero y) '#1) ((even y) (square (exp x (quotient y '#2)))) (t (r* x (square (exp x (quotient y '#2))))))))) (exp rx (i-abs (r-integer y))))) (define (r-negative x) (cond ((rational-p x) (i-negative (numerator (r-normalize x)))) (t (i-negative x)))) (define (r-negate x) (cond ((rational-p x) (let ((nx (r-normalize x))) (make-rational (i-negate (numerator nx)) (denominator nx)))) (t (i-negate x)))) (define (r-max . a) (apply limit r> a)) (define (r-min . a) (apply limit r< a)) (define (r-sqrt square precision) (let ((e (make-rational '#1 (r-expt '#10 (r-natural precision))))) (letrec ((sqr (lambda (x) (cond ((r< (r-abs (r- (r* x x) square)) e) x) (t (sqr (r/ (r+ x (r/ square x)) '#2))))))) (sqr (n-sqrt (r-natural square)))))) (require 'iter) (define * (arithmetic-iterator rational r* '#1)) (define + (arithmetic-iterator rational r+ '#0)) (define (- . x) (cond ((null x) (bottom '(too few arguments to rational -))) ((eq (cdr x) ()) (r-negate (car x))) (t (fold (lambda (a b) (r- (rational a) (rational b))) (car x) (cdr x))))) (define (/ . x) (cond ((null x) (bottom '(too few arguments to rational /))) ((eq (cdr x) ()) (/ '#1 (car x))) (t (fold (lambda (a b) (r/ (rational a) (rational b))) (car x) (cdr x))))) (define < (predicate-iterator rational r<)) (define <= (predicate-iterator rational r<=)) (define = (predicate-iterator rational r=)) (define > (predicate-iterator rational r>)) (define >= (predicate-iterator rational r>=)) (define abs r-abs) (define *epsilon* '#10) (define expt r-expt) (define integer r-integer) (define max r-max) (define min r-min) (define natural r-natural) (define negate r-negate) (define negative r-negative) (define number-p r-number-p) (define one r-one) (define (sqrt x) (r-sqrt x *epsilon*)) (define zero r-zero) zenlisp-2013.11.22/src/0000755000175000017500000000000012243670070013301 5ustar barakbarakzenlisp-2013.11.22/src/amk/0000755000175000017500000000000012243670070014051 5ustar barakbarakzenlisp-2013.11.22/src/amk/amk.l0000644000175000017500000001147011064427500014777 0ustar barakbarak; Another Micro KANREN ; By Nils M Holm, 2006-2008 ; ; Based on "The Reasoned Schemer" by Daniel P. Friedman, et al. ; Inspired by "Sokuza" Mini-KANREN by Oleg Kiselyov. ; ; See the file LICENSE of the zenlisp distribution ; for conditions of use. (define amk :t) (require '~nmath) (define (fail x) ()) (define (succeed x) (list x)) (define failed null) (define (var x) (cons '? x)) (define (_) (var '_)) (define (var-p x) (and (not (atom x)) (eq (car x) '?))) (define empty-s ()) (define :bottom (var ':bottom)) (define (atomic x) (or (atom x) (eq (car x) 'closure))) (define (ext-s x v s) (cons (cons x v) s)) (define (walk x s) (cond ((not (var-p x)) x) (t (let ((v (assq x s))) (cond (v (walk (cdr v) s)) (t x)))))) (define (unify x y s) (let ((x (walk x s)) (y (walk y s))) (cond ((eq x y) s) ((var-p x) (ext-s x y s)) ((var-p y) (ext-s y x s)) ((or (atomic x) (atomic y)) :f) (t (let ((s (unify (car x) (car y) s))) (and s (unify (cdr x) (cdr y) s))))))) (define (== g1 g2) (lambda (s) (let ((s2 (unify g1 g2 s))) (cond (s2 (succeed s2)) (t (fail s)))))) (define (any . g*) (lambda (s) (letrec ((try (lambda g* (cond ((null g*) (fail s)) (t (append ((car g*) s) (apply try (cdr g*)))))))) (apply try g*)))) (define (all . g*) (lambda (s) (letrec ((try (lambda (g* s*) (cond ((null g*) s*) (t (try (cdr g*) (apply append (map (car g*) s*)))))))) (try g* (succeed s))))) (define (one . g*) (lambda (s) (letrec ((try (lambda g* (cond ((null g*) (fail s)) (t (let ((out ((car g*) s))) (cond ((failed out) (apply try (cdr g*))) (t out)))))))) (apply try g*)))) (define (neg g) (lambda (s) (let ((out (g s))) (cond ((failed out) (succeed s)) (t (fail s)))))) (define (choice x lst) (cond ((null lst) fail) (t (any (== x (car lst)) (choice x (cdr lst)))))) (define (occurs x y s) (let ((v (walk y s))) (cond ((var-p y) (eq x y)) ((var-p v) (eq x v)) ((atomic v) :f) (t (or (occurs x (car v) s) (occurs x (cdr v) s)))))) (define (circular x s) (let ((v (walk x s))) (cond ((eq x v) :f) (t (occurs x (walk x s) s))))) (define (walk* x s) (letrec ((w* (lambda (x s) (let ((x (walk x s))) (cond ((var-p x) x) ((atomic x) x) (t (cons (w* (car x) s) (w* (cdr x) s)))))))) (cond ((circular x s) :bottom) ((eq x (walk x s)) empty-s) (t (w* x s))))) (define (preserve-bottom s) (cond ((occurs :bottom s s) ()) (t s))) (define (reify-name n) (implode (append '#_, n))) (define (reify v) (letrec ((reify-s (lambda (v s) (let ((v (walk v s))) (cond ((var-p v) (ext-s v (reify-name (length s)) s)) ((atomic v) s) (t (reify-s (cdr v) (reify-s (car v) s)))))))) (reify-s v empty-s))) (define (run* x g) (preserve-bottom (map (lambda (s) (walk* x (append s (reify (walk* x s))))) (g empty-s)))) (define vp (var 'p)) (define vq (var 'q)) (define (conso a d p) (== (cons a d) p)) (define (caro p a) (conso a (_) p)) (define (cdro p d) (conso (_) d p)) (define (pairo p) (conso (_) (_) p)) (define (eqo x y) (== x y)) (define (nullo a) (eqo a ())) (define (memo x l) (let ((vt (var 't))) (any (caro l x) (all (cdro l vt) (lambda (s) ((memo x vt) s)))))) (define (reverseo l r) (rmemqo r l)) (define (appendo x y r) (any (all (== x ()) (== y r)) (let ((vh (var 'h)) (vt (var 't)) (va (var 'a))) (all (conso vh vt x) (conso vh va r) (lambda (s) ((appendo vt y va) s)))))) (define (memqo x l r) (let ((vt (var 't))) (any (all (caro l x) (== l r)) (all (cdro l vt) (lambda (s) ((memqo x vt r) s)))))) (define (rmemqo x l r) (let ((vt (var 't))) (any (all (cdro l vt) (lambda (s) ((rmemqo x vt r) s))) (all (caro l x) (== l r))))) (define (dupso x r) (let ((vt (var 't)) (vh (var 'h))) (all (conso vh vt x) (one (memqo vh vt r) (lambda (s) ((dupso vt r) s)))))) zenlisp-2013.11.22/src/amk/zebra.l0000644000175000017500000000331211064427516015335 0ustar barakbarak; Another Micro KANREN Example Program ; By Nils M Holm, 2006,2007 ; See the file LICENSE of the ArrowLISP distribution ; for conditions of use. ; Solve the Zebra puzzle: ; zl -n 1024K ; (load zebra) ; (zebra) (require 'amk) (define (lefto x y l) (let ((vt (var 't))) (any (all (caro l x) (cdro l vt) (caro vt y)) (all (cdro l vt) (lambda (s) ((lefto x y vt) s)))))) (define (nexto x y l) (any (lefto x y l) (lefto y x l))) (define (zebra) (let ((h (var 'h))) (run* h (all (== h (list (list 'norwegian (_) (_) (_) (_)) (_) (list (_) (_) 'milk (_) (_)) (_) (_))) (memo (list 'englishman (_) (_) (_) 'red) h) (lefto (list (_) (_) (_) (_) 'green) (list (_) (_) (_) (_) 'ivory) h) (nexto (list 'norwegian (_) (_) (_) (_)) (list (_) (_) (_) (_) 'blue) h) (memo (list (_) 'kools (_) (_) 'yellow) h) (memo (list 'spaniard (_) (_) 'dog (_)) h) (memo (list (_) (_) 'coffee (_) 'green) h) (memo (list 'ukrainian (_) 'tea (_) (_)) h) (memo (list (_) 'luckystrikes 'orangejuice (_) (_)) h) (memo (list 'japanese 'parliaments (_) (_) (_)) h) (memo (list (_) 'oldgolds (_) 'snails (_)) h) (nexto (list (_) (_) (_) 'horse (_)) (list (_) 'kools (_) (_) (_)) h) (nexto (list (_) (_) (_) 'fox (_)) (list (_) 'chesterfields (_) (_) (_)) h) ; (memo (list (_) (_) 'water (_) (_)) h) (memo (list (_) (_) (_) 'zebra (_)) h))))) zenlisp-2013.11.22/src/mexprc/0000755000175000017500000000000012243670070014577 5ustar barakbarakzenlisp-2013.11.22/src/mexprc/m_fac.l0000644000175000017500000000040211064427706016023 0ustar barakbarak; M-Expression Example Program ; By Nils M Holm, 2004-2007 ; See the file LICENSE of the zenlisp distribution ; for conditions of use. ; Compute the factorial of an integer. (require '~mexprc) (mexpr-eval '( m_fac[x] := [x=0 -> 1 : m_fac[x-1] * x] )) zenlisp-2013.11.22/src/mexprc/m_hanoi.l0000644000175000017500000000067611064427706016405 0ustar barakbarak; M-Expression Example Program ; By Nils M Holm, 2004-2007 ; See the file LICENSE of the zenlisp distribution ; for conditions of use. ; Solve the Towers of Hanoi. (require 'mexprc) (mexpr-eval '( m_hanoi[n] := solve[%LEFT, %MIDDLE, %RIGHT, n] where solve[from, to, via, n] := [n=0 -> nil: solve[from, via, to, n-1] ++ list[ list[from, to] ] ++ solve[via, to, from, n-1]] )) zenlisp-2013.11.22/src/mexprc/mexprc.l0000644000175000017500000005701211064427716016266 0ustar barakbarak; MEXPRC -- M-Expression to S-Expression Compiler ; By Nils M Holm, 2003-2008 ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; ; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE ; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS ; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ; SUCH DAMAGE. ; The M-EXPR-COMPILE function accepts a list of symbols representing ; a LISP program in M-expression form and compiles it to an S-expression. ; The M-EXPR-EVAL function compiles and evaluates an M-expr. ; ; M-EXPR-COMPILE currently does not perform much error checking. ; ; The M-expr language accepted by the compiler is (presumably) a subset ; of the M-expr language used in the "LISP 1.5 Programmer's Manual". ; Limitations: ; << and >> are used instead of ( and ) in literal lists ; [ and ] are used instead of ( and ) to group expressions ; : is used instead of ; in conditional operators ; , is used instead of ; to separate list elements ; % is used as a prefix for constants instead of using upper ; case for constants and lower case for variables ; ---example--- ; (mexpr-compile '(f[x] := [x=1 -> 1 : f[x-1]*x])) ; => (define (f x) (cond ((= x '#1) '#1) (t (f (* (- x '#1) x))))) (require '~rmath) (define symbol-class '#abcdefghijklmnopqrstuvwxyz_) (define number-class '#0123456789) (define (symbol-p x) (and (memq x symbol-class) :t)) (define (number-p x) (and (memq x number-class) :t)) ; LEXICAL ANALYSIS IS DONE BELOW. ; ; Input of this stage is a flat list of symbols representing an ; M-expr. Output is a list of individual tokens. For instance, ; ; (f[x] := x=0-> 1: f[x-1]*x) ; gives ; (f [ x ] := x = 0 -> 1 : f [ x - 1 ] * x) ; ; Symbols like F[X] are called 'fragments'. Each fragment ; may contain multiple tokens. F[X] contains F,[,X,]. ; Explode a fragment if necessary. ; (define (explode-on-demand fragment) (cond ((atom fragment) (explode fragment)) (t fragment))) ; Extract a multi-character token from the head of a source fragment. ; (define (extract-class fragment class-p) (letrec ((input (explode-on-demand fragment)) (x-class (lambda (input sym) (cond ((null input) (list (reverse sym) input)) ((class-p (car input)) (x-class (cdr input) (cons (car input) sym))) (t (list (reverse sym) input)))))) (x-class input ()))) (define (extract-symbol fragment) (extract-class fragment symbol-p)) (define (extract-number fragment) (extract-class fragment number-p)) ; Extract a single-character token from the head of a source fragment. ; Value: (token rest-of-fragment) ; (define (extract-char fragment) (let ((input (explode-on-demand fragment))) (list (list (car input)) (cdr input)))) ; Extract a single- or double-character token from the head of a ; source fragment. If the second character of the fragment is ; contained in the ALT-TAILS argument, a two-character token is ; extracted and else a single character is extracted. ; Value: (token rest-of-fragment) ; (define (extract-alternative fragment alt-tails) (let ((input (explode-on-demand fragment))) (cond ((null (cdr input)) (extract-char input)) ((memq (cadr input) alt-tails) (list (list (car input) (cadr input)) (cddr input))) (t (extract-char input))))) ; Recognize tokens and extract them from the head of a source fragment. ; (define (extract-token fragment) (let ((input (explode-on-demand fragment))) (let ((first (car input))) (cond ((eq first '[) (extract-char input)) ((eq first ']) (extract-char input)) ((eq first ',) (extract-char input)) ((eq first '%) (extract-char input)) ((eq first ':) (extract-alternative input '#:=)) ((eq first '+) (extract-alternative input '#+)) ((eq first '-) (extract-alternative input '#>)) ((eq first '*) (extract-char input)) ((eq first '=) (extract-char input)) ((eq first '<) (extract-alternative input '#<>=)) ((eq first '>) (extract-alternative input '#>=)) ((eq first '/) (extract-alternative input '#/\)) ((eq first '\) (extract-alternative input '#/\)) ((eq first '^) (extract-char input)) ((symbol-p first) (extract-symbol input)) ((number-p first) (extract-number input)) (t (bottom 'syntax 'error 'at input)))))) (define frag car) ; fragment of input (define rest cdr) ; rest of input (define restfrag cadr) ; fragment of rest of input (define restrest cddr) ; rest of rest of input ; Extract the first token of the first fragment of a token list. ; If the first fragment is empty (NIL), move to the next ; fragment. ; Value: (extracted-token token-list) ; (define (next-token source) (cond ((null (frag source)) (cond ((null (rest source)) ()) (t (let ((head (extract-token (restfrag source)))) (cons (implode (frag head)) (cons (restfrag head) (restrest source))))))) (t (let ((head (extract-token (frag source)))) (cons (implode (frag head)) (cons (restfrag head) (rest source))))))) ; Lexer. Convert an M-expr to a token list. ; (define (tokenize source) (letrec ((tok (lambda (src tlist) (let ((new-state (next-token src))) (cond ((null new-state) (reverse tlist)) (t (tok (cdr new-state) (cons (car new-state) tlist)))))))) (tok source ()))) ; SYNTAX ANALYSIS IS DONE BELOW. ; ; Input of this stage is a token list as generated during lexical ; analysis. Output is an S-expr that can be reduced using zenlisp. ; For instance, ; ; (F [ x ] := X ^ 2) --> (DEFINE (F X) (EXPT X '#2)) ; ; Most functions of the syntax analysis phase of the compiler return ; partially translated PROGRAMs of the form ; ; (S-EXPR TOKEN-LIST) ; ; where S-EXPR is the S-expr generated from a part of the input program ; and TOKEN-LIST is a token list containing the rest (the not yet ; translated part) of the program. Most parser functions expect input ; in the same form. For instance, ; ; (PARSE-TERM '(() #A*B+C)) => '((* A B) '#+C) ; ; While parsing a program, the S-EXPR part of a PROGRAM structure ; grows and the TOKEN-LIST part shrinks. ; Compose a PROGRAM structure. ; (define (make-prog sexpr tlist) (list sexpr tlist)) ; Functions used to decompose PROGRAM structures. ; (define s-expr-of car) ; S-expression built so far (define rest-of cadr) ; Not yet translated rest of program ; End of input program? ; (define (end-of p) (null (rest-of p))) ; First token of rest of program. ; (define (first-of-rest p) (cond ((end-of p) ()) (t (caadr p)))) ; Rest of rest of program (all but first token of rest). ; (define (rest-of-rest p) (cond ((end-of p) ()) (t (cdadr p)))) ; Look ahead at second token in input stream. ; (define (look-ahead p) (cond ((end-of p) ()) ((null (rest-of-rest p)) ()) (t (car (rest-of-rest p))))) ; Rest^3 of program (all but first two token of rest). ; (define (rest-of-look-ahead p) (cond ((end-of p) ()) ((null (rest-of-rest p)) ()) (t (cdr (rest-of-rest p))))) ; Extract first char of a token ; (define (first-char x) (car (explode x))) ; Turn an expression into a quoted expression: ; X --> (QUOTE X) ; (define (quoted x) (list 'quote x)) ; Parse a list structure, turning it into a list: ; <> --> (QUOTE (A B C)) ; Input lists may contain (unquoted) constants and lists. ; (define (parse-list tlist) (letrec ((plist (lambda (tls skip lst top) ; tls = input ; skip = skip next token (commas) ; lst = output ; top = processing top level list (cond ((eq (car tls) '>>) (cond (top (make-prog (quoted (reverse lst)) (cdr tls))) (t (make-prog (reverse lst) (cdr tls))))) ((eq (car tls) '<<) (let ((sublist (plist (cdr tls) :f () :f))) (plist (rest-of sublist) :t (cons (car sublist) lst) top))) (skip (cond ((eq (car tls) ',) (plist (cdr tls) :f lst top)) (t (bottom ', 'expected 'at tls)))) (t (plist (cdr tls) :t (cons (car tls) lst) top)))))) (plist tlist :f () :t))) (define (unexpected-eot) (bottom 'unexpected-end-of-input)) ; Parse the argument list of a function, returning a list: ; [a+b,c*d] --> ((+ a b) (* c d)) ; (define (parse-actual-args tlist) (letrec ((pargs (lambda (tls skip lst) (cond ((null tls) (unexpected-eot)) ((eq (car tls) ']) (make-prog (reverse lst) (cdr tls))) (skip (cond ((eq (car tls) ',) (pargs (cdr tls) :f lst)) (t (bottom ', 'expected 'at tls)))) (t (let ((expr (parse-expr tls))) (pargs (rest-of expr) :t (cons (car expr) lst)))))))) (pargs tlist :f ()))) ; Parse the formal argument list of a function, returning a list: ; [a,b,c] --> (A B C) ; A formal argument list is a flat list of symbols. ; (define (parse-formal-args tlist) (letrec ((pargs (lambda (tls skip lst) (cond ((null tls) (unexpected-eot)) ((eq (car tls) ']) (make-prog (reverse lst) (cdr tls))) (skip (cond ((eq (car tls) ',) (pargs (cdr tls) :f lst)) (t (bottom ', 'expected 'at tls)))) ((symbol-p (first-char (car tls))) (pargs (cdr tls) :t (cons (car tls) lst))) (t (bottom 'symbol 'expected 'at tls)))))) (pargs tlist :f ()))) ; Parse a function call: ; f[a,b,c] --> (F A B C) ; (define (parse-fun-call program) (let ((function (first-of-rest program)) (args (parse-actual-args (rest-of-look-ahead program)))) (make-prog (append (list function) (s-expr-of args)) (rest-of args)))) ; Parse the argument list of a lambda expression. ; (define (parse-lambda-args program) (cond ((eq (first-of-rest program) '[) (parse-formal-args (rest-of-rest program))) (t (bottom 'argument 'list 'expected 'in 'lambda[])))) ; Compose a lambda expresssion. ; ARGS TERM --> (LAMBDA ARGS TERM) ; (define (make-lambda args term) (list 'lambda args term)) ; Parse an application of a lambda function: ; lambda[[f-args] term][a-args] --> ((LAMBDA (F-ARGS) TERM) A-ARGS) ; (define (parse-lambda-app program) (let ((args (parse-actual-args (rest-of-rest program)))) (make-prog (append (list (s-expr-of program)) (s-expr-of args)) (rest-of args)))) ; Parse a lambda expression. ; lambda[[f-args] term] --> (LAMBDA (F-ARGS) TERM) ; (define (parse-lambda program) (cond ((neq (look-ahead program) '[) (bottom '[ 'expected 'after 'lambda)) (t (let ((args (parse-lambda-args (make-prog () (rest-of-look-ahead program))))) (let ((term (parse-expr (rest-of args)))) (cond ((neq (first-of-rest term) ']) (bottom 'missing 'closing '] 'in 'lambda[])) (t (make-prog (make-lambda (s-expr-of args) (s-expr-of term)) (rest-of-rest term))))))))) ; Create a case of a conditional expression. ; (define (make-case pred expr) (list pred expr)) ; Parse the cases of a conditional expression. ; Value: (list-of-cases rest-of-program) ; where list-of-cases is suitable for building ; a COND expression. ; (define (parse-cases program) (letrec ((pcases (lambda (prog cases) (let ((pred (parse-disj (make-prog () prog)))) (cond ((neq (first-of-rest pred) '->) (make-prog (cons (make-case 't (s-expr-of pred)) cases) (rest-of pred))) (t (let ((expr (parse-expr (rest-of-rest pred)))) (cond ((eq (first-of-rest expr) ':) (pcases (rest-of-rest expr) (cons (make-case (s-expr-of pred) (s-expr-of expr)) cases))) (t (bottom ': 'expected 'in 'conditional 'before (rest-of expr))))))))))) (let ((case-list (pcases (rest-of program) ()))) (make-prog (reverse (s-expr-of case-list)) (rest-of case-list))))) ; Create a COND expression from a list of cases. ; (define (make-cond-expr cases) (cond ((null (cdr cases)) (cadar cases)) (t (cons 'cond cases)))) ; Parse a conditional expression: ; [P1-> X1: P2-> X2: ... : XN ] ; --> (COND (P1 X1) (P2 X2) ... (T XN)) ; (define (parse-cond-expr program) (let ((cond-expr (parse-cases (make-prog () (rest-of-rest program))))) (cond ((neq (first-of-rest cond-expr) ']) (bottom '] 'expected 'at 'end 'of 'conditional 'expression)) (t (make-prog (make-cond-expr (s-expr-of cond-expr)) (rest-of-rest cond-expr)))))) ; Parse a grouped expression: ; [X] --> X ; A grouped expression is just a conditional expression ; with nothing but a default case. ; (define parse-grouped-expr parse-cond-expr) ; Parse a factor of an M-expr. ; (define (parse-factor program) (let ((first (first-char (first-of-rest program)))) (cond ((null first) (unexpected-eot)) ; NIL --> () ((eq (first-of-rest program) 'nil) (make-prog () (rest-of-rest program))) ; TRUE --> :T ((eq (first-of-rest program) 'true) (make-prog :t (rest-of-rest program))) ; FALSE --> :F ((eq (first-of-rest program) 'false) (make-prog :f (rest-of-rest program))) ; LAMBDA[[X] T] --> (LAMBDA (X) T) ; LAMBDA[[X] T][Y] --> ((LAMBDA (X) T) Y) ((eq (first-of-rest program) 'lambda) (let ((lambda-term (parse-lambda program))) (cond ((eq (first-of-rest lambda-term) '[) (parse-lambda-app lambda-term)) (t lambda-term)))) ; SYMBOL --> SYMBOL ; SYMBOL [ ARGS ] --> (SYMBOL ARGS) ((symbol-p first) (cond ((eq (look-ahead program) '[) (parse-fun-call program)) (t (make-prog (first-of-rest program) (rest-of-rest program))))) ; NUMBER --> '#NUMBER ((number-p first) (make-prog (quoted (explode (first-of-rest program))) (rest-of-rest program))) ; << ELEMENT, ... >> --> (QUOTE (ELEMENT ...)) ((eq (first-of-rest program) '<<) (parse-list (rest-of-rest program))) ; %SYMBOL --> (QUOTE SYMBOL) ((eq first '%) (cond ((symbol-p (first-char (look-ahead program))) (let ((rhs (parse-factor (make-prog () (rest-of-rest program))))) (make-prog (quoted (s-expr-of rhs)) (rest-of rhs)))) (t (bottom 'symbol 'expected 'after '%: program)))) ; [ EXPR ] --> EXPR ((eq first '[) (parse-grouped-expr program)) ; -FACTOR --> (- FACTOR) ((eq first '-) (let ((rhs (parse-factor (make-prog () (rest-of-rest program))))) (make-prog (list '- (s-expr-of rhs)) (rest-of rhs)))) (t (bottom 'syntax 'error 'at (rest-of program)))))) ; Parse a binary expression: ; X OP Y OP ... Z --> (FUNCTION (... (FUNCTION X Y) ...) Z) ; This is a generalization of the functions implementing the stages ; of recursive descent parsing. ; (define (parse-binary program ops parent-parser) (letrec ((lhs (parent-parser program)) (collect (lambda (expr tlist) (let ((op (cond ((null tlist) :f) (t (assq (car tlist) ops))))) (cond ((null tlist) (make-prog expr ())) (op (let ((next (parent-parser (make-prog () (cdr tlist))))) (collect (list (cdr op) expr (s-expr-of next)) (rest-of next)))) (t (make-prog expr tlist))))))) (collect (car lhs) (rest-of lhs)))) (define (parse-binary-r program ops parent-parser) (let ((lhs (parent-parser program))) (let ((op (cond ((null (rest-of lhs)) :f) (t (assq (first-of-rest lhs) ops))))) (cond ((null (rest-of lhs)) lhs) (op (let ((rhs (parse-binary-r (make-prog () (rest-of-rest lhs)) ops parent-parser))) (list (list (cdr op) (s-expr-of lhs) (s-expr-of rhs)) (rest-of rhs)))) (t lhs))))) ; Parse concatenation ops: ; X::Y --> (CONS X Y) ; X++Y --> (APPEND X Y) ; (define (parse-concat program) (parse-binary-r program '((:: . cons) (++ . append)) parse-factor)) ; Parse powers: ; X^Y --> (EXPT X Y) ; (define (parse-power program) (parse-binary-r program '((^ . expt)) parse-concat)) ; Parse terms: ; X*Y --> (* X Y) ; X/Y --> (/ X Y) ; (define (parse-term program) (parse-binary program '((* . *) (/ . /) (// . quotient) (\\ . remainder)) parse-power)) ; Parse sums: ; X+Y --> (+ X Y) ; X-Y --> (- X Y) ; (define (parse-sum program) (parse-binary program '((+ . +) (- . -)) parse-term)) ; Parse predicates: ; X=Y --> (= X Y) ; X<>Y --> ((LAMBDA (X Y) (NOT (= X Y))) X Y) ; X (< X Y) ; X>Y --> (> X Y) ; X<=Y --> (<= X Y) ; X>=Y --> (>= X Y) ; (define (parse-pred program) (parse-binary program '((= . =) (<> . (lambda (x y) (not (= x y)))) (< . <) (> . >) (<= . <=) (>= . >=)) parse-sum)) ; Parse logical conjunctions: ; X/\Y --> (AND X Y) ; (define (parse-conj program) (parse-binary program '((/\ . and)) parse-pred)) ; Parse logical disjunctions: ; X\/Y --> (OR X Y) ; (define (parse-disj program) (parse-binary program '((\/ . or)) parse-conj)) ; Parse a token list representing an M-expr, ; returning a program of the form: ; ; (S-EXPR (REST OF TOKEN LIST)) ; (define (parse-expr tlist) (parse-disj (make-prog () tlist))) ; Accept a definition of the form ; F[ARGS] := EXPR ; ; Return a partial environment of the form ; (F (LAMBDA (ARGS) EXPR)) ; in the CAR part of the resulting PROGRAM. ; (define (internal-definition program) (let ((head (parse-expr (rest-of program)))) (cond ((eq (first-of-rest head) ':=) (let ((term (parse-expr (rest-of-rest head)))) (make-prog (list (car (s-expr-of head)) (make-lambda (cdr (s-expr-of head)) (s-expr-of term))) (rest-of term)))) (t (bottom ':= 'expected 'at (rest-of program)))))) ; Parse the WHERE clause of a compound definition: ; WHERE F[ARGS] := EXPR AND G[ARGS] := EXPR ... ; Return an environment for LETREC in the CAR of ; the resulting PROGRAM: ; ( (F (LAMBDA (ARGS) EXPR)) ; (G (LAMBDA (ARGS) EXPR)) ) ; (define (parse-compound program) (letrec ((compound (lambda (prog def-list) (let ((defn (internal-definition (make-prog () prog)))) (cond ((eq (first-of-rest defn) 'and) (compound (rest-of-rest defn) (cons (s-expr-of defn) def-list))) (t (make-prog (reverse (cons (s-expr-of defn) def-list)) (rest-of defn)))))))) (compound program ()))) ; Create a LETREC out of an environment and a term. ; (define (make-letrec env term) (list 'letrec env term)) ; Parse definitions of the forms ; F[ARGS] := EXPR ; and ; F[ARGS] := EXPR WHERE G[ARGS] := EXPR AND ... ; ; Upon entry, PROGRAM holds ((F ARGS) (:= EXPR)) ; This function merely composes an application of ; DEFINE and returns it. ; (define (parse-definition program) (let ((term (parse-expr (rest-of-rest program)))) (cond ((eq (first-of-rest term) 'where) (let ((compound (parse-compound (rest-of-rest term)))) (make-prog (list 'define (s-expr-of program) (make-letrec (s-expr-of compound) (s-expr-of term))) (rest-of compound)))) (t (make-prog (list 'define (s-expr-of program) (s-expr-of term)) (rest-of term)))))) ; Parse an M-expr (including definitions), returning ; an equivalent S-expr in the CAR part of the resulting ; PROGRAM. ; (define (parse-program tlist) (let ((program (parse-expr tlist))) (cond ((eq (first-of-rest program) ':=) (parse-definition program)) (t program)))) ; Compile an M-expr to an S-expr. ; (define (mexpr-compile source) (let ((program (parse-program (tokenize source)))) (cond ((end-of program) (car program)) (t (bottom 'syntax 'error 'at (rest-of program)))))) ; Compile and evaluate an M-expr. ; (define (mexpr-eval source) (eval (mexpr-compile source))) zenlisp-2013.11.22/src/mexprc/m_append.l0000644000175000017500000000053511064427704016546 0ustar barakbarak; M-Expression Example Program ; By Nils M Holm, 2004-2007 ; See the file LICENSE of the zenlisp distribution ; for conditions of use. ; Append two lists. (require '~mexprc) (mexpr-eval '( m_append[a,b] := r_append[reverse[a], b] where r_append[a,b] := [null[a] -> b: r_append[cdr[a], car[a]::b]] )) zenlisp-2013.11.22/src/mexprc/m_queens.l0000644000175000017500000000176111064427710016576 0ustar barakbarak; M-Expression Example Program ; By Nils M Holm, 2004-2007 ; See the file LICENSE of the zenlisp distribution ; for conditions of use. ; Solve the N-Queens puzzle. (require 'mexprc) (mexpr-eval '( m_queens[size] := n_queens[0, 0, nil] where n_queens[q, c, b] := [c = size -> reverse[b]: column[q] <> c -> [null[b] -> nil: n_queens[car[b]+1, c-1, cdr[b]]]: safe_place[q, b] -> n_queens[next_column[q], c+1, q::b]: n_queens[q+1, c, b]] and column[x] := x // size and row[x] := x \\ size and safe_place[x,b] := [null[b] -> true: connected[car[b], x] -> false: safe_place[x, cdr[b]]] and connected[x,y] := common_h_v[x,y] \/ common_dia[x,y] and common_h_v[x,y] := row[x] = row[y] \/ column[x] = column[y] and common_dia[x,y] := abs[column[x]-column[y]] = abs[row[x]-row[y]] and next_column[q] := [q+size] // size * size )) zenlisp-2013.11.22/src/misc/0000755000175000017500000000000012243670070014234 5ustar barakbarakzenlisp-2013.11.22/src/misc/quine.l0000644000175000017500000000030611064427732015536 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; A zenlisp quine. ((lambda #x (list x (list 'quote x))) '(lambda #x (list x (list 'quote x)))) zenlisp-2013.11.22/src/misc/records.l0000644000175000017500000001020111064427732016051 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; Emulate the ML-style record datatype ; without mutation and with only rudimentary type checking. ; (record '(a test) '(b #17) (c (a list))) ; => '((%record) (a test) (b #17) (c (a list))) ; (define r **) ; (record-ref r 'b) => '#17 ; (record-equal r r) => :t ; (record-signature r) => '((%record) (a atom) (b number) (c pair)) ; (record-set r 'b '#25) => '((%record) (a test) (b #25) (c (a list))) ; (record-set r 'b 'xyz) => bottom ; type check (or (defined 'nmath) (defined 'imath) (defined 'rmath) (load ~rmath)) (define record-tag (list '%record)) (define (pair-p x) (not (atom x))) (define (boolean-p x) (or (eq x :t) (eq x :f))) (define (closure-p x) (and (pair-p x) (eq (car x) 'closure))) (define (record-p x) (and (pair-p x) (eq (car x) record-tag))) (define (list->record a) (letrec ((valid-fields-p (lambda (a) (or (null a) (and (pair-p (car a)) (atom (caar a)) (pair-p (cdar a)) (null (cddar a)) (valid-fields-p (cdr a))))))) (cond ((valid-fields-p a) (cons record-tag a)) (t (bottom 'bad-record-structure a))))) (define (record . x) (list->record x)) (define (record->list r) (cond ((record-p r) (cdr r)) (t (bottom 'expected-record-got r)))) (define (record-field r tag) (let ((v (assq tag (record->list r)))) (cond (v v) (t (bottom 'no-such-tag (list 'record: r 'tag: tag)))))) (define (record-ref r tag) (cadr (record-field r tag))) (define (type-of x) (cond ((boolean-p x) 'boolean) ((null x) 'pair) ((atom x) 'symbol) ((number-p x) 'number) ((record-p x) 'record) ((closure-p x) 'function) ((pair-p x) 'pair) (t (bottom 'unknown-type x)))) (define (record-equal r1 r2) (letrec ((equal-fields-p (lambda (r1 r2) (cond ((null r1) :t) (t (let ((x (assq (caar r1) r2))) (and x (equal (cadar r1) (cadr x)) (equal-fields-p (cdr r1) r2)))))))) (let ((lr1 (record->list r1)) (lr2 (record->list r2))) (and (= (length lr1) (length lr2)) (equal-fields-p lr1 lr2))))) (define (equal a b) (cond ((eq a b) :t) ((and (pair-p a) (pair-p b)) (and (equal (car a) (car b)) (equal (cdr a) (cdr b)))) ((record-p a) (and (record-p b) (record-equal a b))) (t :f))) (define (record-signature r) (letrec ((make-sig (lambda (x) (map (lambda (x) (cond ((record-p (cadr x)) (list (car x) (list (type-of (cadr x)) (record-signature (cadr x))))) (t (list (car x) (type-of (cadr x)))))) x)))) (list->record (make-sig (record->list r))))) (define (record-set r tag v) (letrec ((subst (lambda (r old new) (cond ((null r) ()) ((eq old (car r)) (cons new (cdr r))) (t (cons (car r) (subst (cdr r) old new)))))) (type-mismatch (lambda () (bottom 'type-mismatch (list 'record: r 'tag: tag 'value: v))))) (let ((f (record-field r tag))) (let ((b (cdr f))) (cond ((eq (type-of (car b)) (type-of v)) (cond ((or (not (record-p v)) (record-equal (record-signature (car b)) (record-signature v))) (subst r f (list (car f) v))) (t (type-mismatch)))) (t (type-mismatch))))))) (define (record-type-matches-p sig r) (record-equal sig (record-signature r))) (define (assert-record-type sig r) (cond ((not (record-type-matches-p sig r)) (bottom 'record-type-assertion-failed (list 'signature: sig 'record: r))) (t r))) zenlisp-2013.11.22/src/misc/queens.l0000644000175000017500000000444711064427730015725 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2008 ; See the file LICENSE for conditions of use. ; Solve the N-queens problem. ; (queens '#4) ; (queens '#5 '#2) ; print only two solutions (require '~nmath) (define (queens board-size . limit) (letrec ((column (lambda (x) (quotient x board-size))) (row (lambda (x) (remainder x board-size))) (incr (lambda (x) (+ '#1 x))) (decr (lambda (x) (- x '#1))) (can-attack-straight-p (lambda (x y) (or (= (row x) (row y)) (= (column x) (column y))))) (abs-diff (lambda (x y) (cond ((< x y) (- y x)) (t (- x y))))) (can-attack-diagonal-p (lambda (x y) (= (abs-diff (column x) (column y)) (abs-diff (row x) (row y))))) (can-attack-p (lambda (x y) (or (can-attack-straight-p x y) (can-attack-diagonal-p x y)))) (safe-place-p (lambda (x b) (cond ((null b) :t) ((can-attack-p (car b) x) :f) (t (safe-place-p x (cdr b)))))) (next-column (lambda (q) (* (quotient (+ q board-size) board-size) board-size))) (solve (lambda (q c b r k) (cond ((equal c board-size) (cond ((or (null limit) (< k (car limit))) (solve (incr (car b)) (decr c) (cdr b) (cons b r) (+ '#1 k))) (t r))) ((> (column q) c) (cond ((null b) r) (t (solve (incr (car b)) (decr c) (cdr b) r k)))) ((safe-place-p q b) (solve (next-column q) (incr c) (cons q b) r k)) (t (solve (incr q) c b r k)))))) (map (lambda (b*) (map (lambda (x) (remainder x board-size)) b*)) (reverse (solve '#0 '#0 () () '#0))))) zenlisp-2013.11.22/src/misc/o.l0000644000175000017500000000025011064427726014654 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Represent the undefined value: ; (o) => bottom (define (o) (o)) zenlisp-2013.11.22/src/misc/hanoi.l0000644000175000017500000000073011064427726015517 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Solve the Towers of Hanoi: ; (hanoi '#iii) => '(#ab #ac #bc #ab #ca #cb #ab) (define (hanoi n) (letrec ((hanoi4 (lambda (from to via n) (cond ((null n) ()) (t (append (hanoi4 from via to (cdr n)) (list (list from to)) (hanoi4 via to from (cdr n)))))))) (hanoi4 'a 'b 'c n))) zenlisp-2013.11.22/src/misc/gener.l0000644000175000017500000000074111064427724015521 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Create a generator: ; (load ~nmath) ; (generator '#0 (lambda (x) (+ x '#1))) => '(#0 . (closure ())) ; ((cdr **)) => '(#1 . (closure ())) ; ((cdr **)) => '(#2 . (closure ())) ; ((cdr **)) => '(#3 . (closure ())) ; ... (define (value g) (car g)) (define (next g) ((cdr g))) (define (generator start step) (lambda () (cons start (generator (step start) step)))) zenlisp-2013.11.22/src/misc/bottles.l0000644000175000017500000000432711064427724016101 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Bottles Song in Pure LISP ; ; This is purely symbolic lisp. ; There are no pre-defined numbers, not even digits. ; There are no strings. ; There is no input/output. ; There are no side effects. ; ; Numbers are represented by lists of digits. ; ; Lyrics are generated in this format: ; ; ((#99 bottles of beer on the wall) ; (#99 bottles of beer) ; (take one down and pass it around) ; (#98 bottles of beer on the wall)) (define (bottles) (letrec ((beer-on-wall (quote (bottles of beer on the wall))) (beer (quote (bottles of beer))) (take-down (quote (take one down and pass it around))) (append (lambda (a b) (cond ((null a) b) (t (cons (car a) (append (cdr a) b)))))) (append4 (lambda (a b c d) (append a (append b (append c d))))) (pred (lambda (n) (cond ((eq n (quote 1)) (quote 0)) ((eq n (quote 2)) (quote 1)) ((eq n (quote 3)) (quote 2)) ((eq n (quote 4)) (quote 3)) ((eq n (quote 5)) (quote 4)) ((eq n (quote 6)) (quote 5)) ((eq n (quote 7)) (quote 6)) ((eq n (quote 8)) (quote 7)) ((eq n (quote 9)) (quote 8)) (t :f)))) (cadr (lambda (x) (car (cdr x)))) (list (lambda (x) (cons x ()))) (decrement (lambda (n) (cond ((pred (cadr n)) (cons (car n) (list (pred (cadr n))))) (t (cons (pred (car n)) (list (quote 9))))))) (zerop (lambda (n) (cond ((eq (car n) (quote 0)) (eq (cadr n) (quote 0))) (t :f)))) (verse (lambda (n) (append4 (list (append (list n) beer-on-wall)) (list (append (list n) beer)) (list take-down) (list (append (list (decrement n)) beer-on-wall))))) (count-bottles (lambda (n lyrics) (cond ((zerop n) lyrics) (t (count-bottles (decrement n) (append lyrics (list (verse n))))))))) (count-bottles (quote (9 9)) ()))) zenlisp-2013.11.22/src/misc/streams.l0000644000175000017500000000235211064427734016100 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2008 ; See the file LICENSE for conditions of use. (define (stream v first filter rest lim final) (letrec ((find (lambda (x) (cond ((lim x) x) ((filter (first x)) x) (t (find (rest x)))))) (make-stream (lambda (v) (lambda () (let ((nf (find v))) (cond ((lim nf) final) (t (cons (first nf) (make-stream (rest nf)))))))))) ((make-stream v)))) (define (all x) :t) (define (none x) :f) (define (value s) (car s)) (define (next s) ((cdr s))) (define pass not) (define (list->stream v) (stream v car all cdr null :f)) (define (stream->list s) (letrec ((s->l (lambda (s lst) (cond (s (s->l (next s) (cons (value s) lst))) (t (reverse lst)))))) (s->l s ()))) (define (stream-member p s d) (cond ((eq s d) d) ((p (value s)) s) (t (stream-member p (next s) d)))) (define (map-stream f s) (stream s (lambda (s) (f (value s))) all next pass :f)) (define (filter-stream p s) (stream s value p next pass :f)) (define (append-streams s1 s2) (stream s1 value all next pass s2)) zenlisp-2013.11.22/src/lists/0000755000175000017500000000000012243670070014437 5ustar barakbarakzenlisp-2013.11.22/src/lists/count.l0000644000175000017500000000050011064427644015746 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Recursively count the atoms of a list: ; (count '(a (b (c)))) => '#3 (require '~nmath) (define (count x) (cond ((null x) '#0) ((atom x) '#1) (t (+ (count (car x)) (count (cdr x)))))) zenlisp-2013.11.22/src/lists/depth.l0000644000175000017500000000056211064427646015734 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute the depth of a list. The depth ; of a list is the maximum number of ; lists enclosing any atom of the list. ; ; (depth '(a b (c (d) e) ((f)))) => '#3 (require '~nmath) (define (depth a) (cond ((atom a) '#0) (t (+ '#1 (apply max (map depth a)))))) zenlisp-2013.11.22/src/lists/filter.l0000644000175000017500000000104511064427650016105 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Extract members matching a given predicate: ; (filter atom '(abc #123 def #456 ghi)) => '(abc def ghi) (define (filter p a) (letrec ((filter2 (lambda (a b) (cond ((null a) b) ((p (car a)) (filter2 (cdr a) (cons (car a) b))) (t (filter2 (cdr a) b)))))) (filter2 (reverse a) ()))) ; Using PARTITION: ; (require 'partition) ; (define (filter p a) ; (car (partition p a))) zenlisp-2013.11.22/src/lists/flatten.l0000644000175000017500000000056411064427650016262 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; Flatten a tree: ; (flatten '((a) (b (c)) (d (e (f))))) => '#abcdef (define (flatten x) (letrec ((f (lambda (x r) (cond ((null x) r) ((atom x) (cons x r)) (t (f (car x) (f (cdr x) r))))))) (f x ()))) zenlisp-2013.11.22/src/lists/fold-left.l0000644000175000017500000000120211064427652016471 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; R6RS Scheme-style FOLD-LEFT. This function is like FOLD, ; but accepts multiple list arguments: ; (fold-left list '0 '(a b c) '(d e f)) => '((#0ad b e) c f) (define (fold-left f b . a*) (letrec ((car-of (lambda (a) (map car a))) (cdr-of (lambda (a) (map cdr a))) (fold (lambda (a* r) (cond ((null (car a*)) r) (t (fold (cdr-of a*) (apply f r (car-of a*)))))))) (cond ((null a*) (bottom 'too-few-arguments)) (t (fold a* b))))) zenlisp-2013.11.22/src/lists/fold-right.l0000644000175000017500000000132311064427652016660 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; R6RS Scheme-style FOLD-RIGHT. This function is like FOLD-R, ; but accepts multiple list arguments: ; (fold-right list '0 '(a b c) '(d e f)) => '(a d (b e #cf0)) (define (fold-right f b . a*) (letrec ((car-of (lambda (a) (map car a))) (cdr-of (lambda (a) (map cdr a))) (foldr (lambda (a* r) (cond ((null (car a*)) r) (t (foldr (cdr-of a*) (apply f (append (car-of a*) (list r))))))))) (cond ((null a*) (bottom 'too-few-arguments)) (t (foldr (map reverse a*) b))))) zenlisp-2013.11.22/src/lists/headp.l0000644000175000017500000000055011064427654015705 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Check whether an expression X is the head of an expression Y: ; (headp '(a b c) '(a b c d e f)) => 't (define (headp x y) (cond ((null y) (null x)) ((null x) :t) (t (and (equal (car x) (car y)) (headp (cdr x) (cdr y)))))) zenlisp-2013.11.22/src/lists/tailp.l0000644000175000017500000000065511064427666015746 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Check if an expression X is equal to the tail ; of an expression Y: ; (tailp '(d e f) '(a b c d e f)) => 't (require 'headp) (define (tailp x y) (headp (reverse x) (reverse y))) ; Without using HEADP: ; (define (tailp x y) ; (cond ((null y) (null x)) ; (t (or (equal x y) ; (tailp x (cdr y)))))) zenlisp-2013.11.22/src/lists/last.l0000644000175000017500000000031511064427656015570 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Extract the last member of a list: ; (last '(a b c d e f)) => 'f (define (last x) (car (reverse x))) zenlisp-2013.11.22/src/lists/replace.l0000644000175000017500000000056111064427662016240 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Replace OLD by NEW in EXPR: ; (replace 'x 'z '(a x (x) (x z))) => '(a z #z #zz) (define (replace old new form) (cond ((equal form old) new) ((atom form) form) (t (cons (replace old new (car form)) (replace old new (cdr form)))))) zenlisp-2013.11.22/src/lists/substitute.l0000644000175000017500000000105511064427664017041 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Substitute variables in S-expressions. ; (substitute '(+ 1 2) '((1.i) (2.ii))) => '(+ i ii) (define (substitute x env) (letrec ((value-of (lambda (x) (let ((v (assq x env))) (cond (v (cdr v)) (t x))))) (subst (lambda (x) (cond ((null x) ()) ((atom x) (value-of x)) (t (cons (subst (car x)) (subst (cdr x)))))))) (subst x))) zenlisp-2013.11.22/src/lists/remove.l0000644000175000017500000000040311064427662016115 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Remove members from a list. ; (remove atom '(abc #123 def #456 ghi)) => '(#123 #456) (define (remove p x) (filter (lambda (x) (not (p x))) x)) zenlisp-2013.11.22/src/lists/pair.l0000644000175000017500000000036411064427660015557 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Build an association list from two lists: ; (pair '(1 2 3) '(i ii iii)) => '((1 . i) (2 . ii) (3 . iii)) (define (pair a b) (map cons a b)) zenlisp-2013.11.22/src/lists/partition.l0000644000175000017500000000121311064427662016631 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; Partition a list according to some predicate: ; (partition atom '(#1 alpha #2 beta)) => '((alpha beta) (#1 #2)) (define (partition p a) (letrec ((partition3 (lambda (a r+ r-) (cond ((null a) (list r+ r-)) ((p (car a)) (partition3 (cdr a) (cons (car a) r+) r-)) (t (partition3 (cdr a) r+ (cons (car a) r-))))))) (partition3 (reverse a) () ()))) zenlisp-2013.11.22/src/lists/nth.l0000644000175000017500000000052411064427660015413 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Extract the tail of a list starting at the n'th ; member of that list: ; (nth '#2 '#abcdef) => '#cdef (require '~nmath) (define (nth n x) (cond ((zero n) x) ((null x) :f) (t (nth (- n '#1) (cdr x))))) zenlisp-2013.11.22/src/math/0000755000175000017500000000000012243670070014232 5ustar barakbarakzenlisp-2013.11.22/src/math/transpose.l0000644000175000017500000000035311064427704016432 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; Transpose (swap rows and columns of) a matrix: ; (transpose '(#abc #def)) => '(#ad #be #cf) (define (transpose x) (apply map list x)) zenlisp-2013.11.22/src/math/hyper.l0000644000175000017500000000100111064427700015526 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute A hyperN B: ; (hyper '#4 '#3 '#3) => '#7625597484987 ; A, B, and N must all be natural. (require '~nmath) (define (hyper n a b) (cond ((equal n '#0) (+ '#1 a)) ((equal n '#1) (+ a b)) ((one b) a) ((equal n '#2) (* a b)) ((equal n '#3) (expt a b)) ((equal n '#4) (expt a (hyper n a (- b '#1)))) ((> n '#4) (hyper (- n '#1) a (hyper n a (- b '#1)))))) zenlisp-2013.11.22/src/math/product.l0000644000175000017500000000076111064427702016075 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute the product of a sequence of numbers: ; (product '#5 '#7) => '#210 (require '~nmath) (define (product lo hi) (letrec ((prod (lambda (x lim res) (cond ((> x lim) res) (t (prod (+ '#1 x) lim (* res x))))))) (let ((n-lo (natural lo)) (n-hi (natural hi))) (prod (min n-lo n-hi) (max n-lo n-hi) '#1)))) zenlisp-2013.11.22/src/math/sum.l0000644000175000017500000000106411064427704015220 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute the sum of a sequence of positive numbers: ; (sum '#2 '#5) => '#14 (require '~nmath) (define (sum n m) (letrec ((s (lambda (n m) (let ((x (+ '#1 (- m n)))) (+ (quotient (+ (* x x) x) '#2) (* (- n '#1) x)))))) (let ((nn (natural n)) (nm (natural m))) (cond ((or (zero nn) (zero nm)) (bottom 'sum n m)) (t (s (min nn nm) (max nn nm))))))) zenlisp-2013.11.22/src/math/iota.l0000644000175000017500000000055311064427700015346 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Generate a sequence of integer numbers: ; (iota '#5 '#10) => '(#5 #6 #7 #8 #9 #10) (require '~imath) (define (iota lo hi) (letrec ((j (lambda (x r) (cond ((< x lo) r) (t (j (- x '#1) (cons x r))))))) (j (integer hi) ()))) zenlisp-2013.11.22/src/math/make-partitions.l0000644000175000017500000000156711064427702017531 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; Create the number-theoretic partitions of an integer N: ; (make-partitions '#3) => '((#3) (#1 #2) (#1 #1 #1)) (require '~nmath) (require 'iota) (define (make-partitions n) (letrec ((partition (lambda (n) (cond ((zero n) '(())) ((one n) '((#1))) (t (apply append (map (lambda (x) (map (lambda (p) (cons x p)) (partition (- n x)))) (iota '#1 n))))))) (filter-descending (lambda (p) (cond ((null (cdr p)) p) ((apply >= (car p)) (cons (car p) (filter-descending (cdr p)))) (t (filter-descending (cdr p))))))) (reverse (filter-descending (partition n))))) zenlisp-2013.11.22/src/math/factorial.l0000644000175000017500000000063211064427676016370 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute X!: ; (factorial '#5) => '#120 (require '~nmath) (define (factorial n) (letrec ((r* (lambda (n k) (cond ((< k '#2) n) (t (let ((l (quotient k '#2))) (* (r* n l) (r* (+ n l) (- k l))))))))) (r* '#1 (natural n)))) zenlisp-2013.11.22/src/math/factors.l0000644000175000017500000000271111064427676016065 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Factor integers down to their constituent primes: ; (factors '#24) => '((#3 #1) (#2 #3)) (require '~nmath) (define (factors n) (letrec ((quotient+exponent (lambda (n m) (letrec ((div (lambda (n m r) (let ((qr (divide n m))) (cond ((zero (cadr qr)) (div (car qr) m (+ '#1 r))) (t (cons n r))))))) (div n m '#0)))) (add-expt (lambda (b e r) (cond ((zero e) r) (t (cons (list b e) r))))) (factorize (lambda (n d r) (let ((lim (sqrt n))) (letrec ((factorize3 (lambda (n d r) (let ((rest/exp (quotient+exponent n d))) (let ((q (car rest/exp)) (e (cdr rest/exp))) (cond ((< q '#2) (add-expt d e r)) ((> d lim) (add-expt n '#1 r)) (t (factorize3 q (cond ((= d '#2) '#3) (t (+ d '#2))) (add-expt d e r))))))))) (factorize3 n d r)))))) (cond ((< n '#1) (bottom 'operand-not-positive n)) ((= n '#1) '#1) (t (factorize n '#2 ()))))) zenlisp-2013.11.22/src/logic/0000755000175000017500000000000012243670070014376 5ustar barakbarakzenlisp-2013.11.22/src/logic/any.l0000644000175000017500000000045311064427666015357 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Return the first member having a given property or :f. ; (any atom '((a b c) x (d e f))) => 't (define (any p x) (cond ((null x) :f) ((p (car x)) (car x)) (t (any p (cdr x))))) zenlisp-2013.11.22/src/logic/every.l0000644000175000017500000000051111064427670015710 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Check whether all members of a list have a given property: ; (every atom '(a b c)) => 't (define (every p x) (cond ((null x) :t) ((null (cdr x)) (p (car x))) ((p (car x)) (every p (cdr x))) (t :f))) zenlisp-2013.11.22/src/logic/some.l0000644000175000017500000000051711064427674015533 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Extract the tail of a list (where the first member ; of the tail has a given property) or :f. ; (some null '(a b () c d)) => '(() c d) (define (some p x) (cond ((null x) :f) ((p (car x)) x) (t (some p (cdr x))))) zenlisp-2013.11.22/src/logic/exists.l0000644000175000017500000000111211064427670016073 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; R6RS Scheme-style EXISTS. This function is like ANY, ; but accepts multiple list arguments: ; (require '~nmath) ; (exists < '(#1 #2 #3) '(#1 #1 #4)) => :t (define (exists p . a*) (letrec ((car-of (lambda (a) (map car a))) (cdr-of (lambda (a) (map cdr a))) (exists* (lambda (a*) (cond ((null (car a*)) :f) (t (or (apply p (car-of a*)) (exists* (cdr-of a*)))))))) (exists* a*))) zenlisp-2013.11.22/src/logic/for-all.l0000644000175000017500000000123211064427672016115 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; R6RS Scheme-style FOR-ALL. This function is like EVERY, ; but accepts multiple list arguments: ; (require '~nmath) ; (for-all < '(#1 #1 #1) '(#2 #2 #2)) => :t (define (for-all p . a*) (letrec ((car-of (lambda (a) (map car a))) (cdr-of (lambda (a) (map cdr a))) (forall* (lambda (a*) (cond ((null (car a*)) :t) ((null (cdar a*)) (apply p (car-of a*))) (t (and (apply p (car-of a*)) (forall* (cdr-of a*)))))))) (forall* a*))) zenlisp-2013.11.22/src/logic/combine.l0000644000175000017500000000174011064427666016204 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Create combinations of a set with (COMBINE*) ; and without (COMBINE) repetition: ; (combine '#2 '(a b c)) => '(#ab #ac #bc) ; (combine* '#2 '(a b c)) => '(#aa #ab #ac #bb #bc #cc) (require '~nmath) (define (combine3 n set rest) (letrec ((tails-of (lambda (set) (cond ((null set) ()) (t (cons set (tails-of (cdr set))))))) (combinations (lambda (n set) (cond ((zero n) ()) ((one n) (map list set)) (t (apply append (map (lambda (tail) (map (lambda (sub) (cons (car tail) sub)) (combinations (- n '#1) (rest tail)))) (tails-of set)))))))) (combinations n set))) (define (combine n set) (combine3 n set cdr)) (define (combine* n set) (combine3 n set id)) zenlisp-2013.11.22/src/logic/permute.l0000644000175000017500000000265511064427672016254 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Create permutations of a set with (PERMUTE*) ; and without (PERMUTE) repetition: ; (permute '#2 '(a b)) => '(#ab #ba) ; (permute* '#2 '(a b)) => '(#aa #ab #ba #bb) (require 'combine) (define (permute n set) (letrec ((rotate (lambda (x) (append (cdr x) (list (car x))))) (rotations (lambda (x) (letrec ((rot (lambda (x n) (cond ((null n) ()) (t (cons x (rot (rotate x) (cdr n)))))))) (rot x x)))) (permutations (lambda (set) (cond ((null set) ()) ((null (cdr set)) (list set)) ((null (cddr set)) (rotations set)) (t (apply append (map (lambda (rotn) (map (lambda (x) (cons (car rotn) x)) (permutations (cdr rotn)))) (rotations set)))))))) (apply append (map permutations (combine n set))))) (define (permute* n set) (cond ((zero n) ()) ((one n) (map list set)) (t (apply append (map (lambda (x) (map (lambda (sub) (cons x sub)) (permute* (- n '#1) set))) set))))) zenlisp-2013.11.22/src/sets/0000755000175000017500000000000012243670070014257 5ustar barakbarakzenlisp-2013.11.22/src/sets/union.l0000644000175000017500000000040711064427736015576 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute the union of some sets: ; (union '(aa ab) '(ab ac) '(ac ad) ()) => '(aa ab ac ad) (require '~unique) (define (union . a) (unique (apply append a))) zenlisp-2013.11.22/src/sets/intersection.l0000644000175000017500000000103611064427734017151 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Compute the intersection of some sets: ; (intersection '#abcd '#bcde '#cdef) => '#cd (define (intersection . a) (letrec ((intersection3 (lambda (a b r) (cond ((null a) (reverse r)) ((member (car a) b) (intersection3 (cdr a) b (cons (car a) r))) (t (intersection3 (cdr a) b r)))))) (fold (lambda (a b) (intersection3 a b ())) (car a) a))) zenlisp-2013.11.22/src/sets/listtoset.l0000644000175000017500000000075311064427736016504 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Transform a list into a set (a list containing ; only unique elements): ; (list->set '(aa ab ac ad ab aa)) => '(aa ab ac ad) (define (list->set a) (letrec ((l->s (lambda (a r) (cond ((null a) (reverse r)) ((member (car a) r) (l->s (cdr a) r)) (t (l->s (cdr a) (cons (car a) r))))))) (l->s a ()))) zenlisp-2013.11.22/src/sort/0000755000175000017500000000000012243670070014270 5ustar barakbarakzenlisp-2013.11.22/src/sort/bubblesort.l0000644000175000017500000000136111064427740016615 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Sort a list using the bubblesort algorithm: ; (require '~nmath) ; (bubblesort < '(#5 #1 #7 #2 #6)) => '(#1 #2 #5 #6 #7) (require 'orderedp) (define (bubblesort p x) (letrec ((bubble-up (lambda (x) (cond ((or (null x) (null (cdr x))) x) ((p (car x) (cadr x)) (cons (car x) (bubble-up (cdr x)))) (t (cons (cadr x) (bubble-up (cons (car x) (cddr x)))))))) (bubble-step (lambda (x) (cond ((orderedp p x) x) (t (bubble-step (bubble-up x))))))) (bubble-step x))) zenlisp-2013.11.22/src/sort/mergesort.l0000644000175000017500000000226311064427742016465 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Sort a list using the Mergesort algorithm: ; (require '~nmath) ; (mergesort <= '(#5 #1 #3 #2 #4)) => '(#1 #2 #3 #4 #5) (define (mergesort p a) (letrec ((split (lambda (a r1 r2) (cond ((or (null a) (null (cdr a))) (list (reverse r2) r1)) (t (split (cddr a) (cdr r1) (cons (car r1) r2)))))) (merge (lambda (a b r) (cond ((null a) (cond ((null b) r) (t (merge a (cdr b) (cons (car b) r))))) ((null b) (merge (cdr a) b (cons (car a) r))) ((p (car a) (car b)) (merge a (cdr b) (cons (car b) r))) (t (merge (cdr a) b (cons (car a) r)))))) (sort (lambda (a) (cond ((or (null a) (null (cdr a))) a) (t (let ((p* (split a a ()))) (merge (reverse (sort (car p*))) (reverse (sort (cadr p*))) ()))))))) (sort a))) zenlisp-2013.11.22/src/sort/quicksort.l0000644000175000017500000000116311064427744016502 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Sort a list using the Quicksort algorithm: ; (require '~nmath) ; (quicksort <= '(#5 #1 #3 #2 #4)) => '(#1 #2 #3 #4 #5) (require 'partition) (define (quicksort p a) (letrec ((sort (lambda (a) (cond ((or (null a) (null (cdr a))) a) (t (let ((p* (partition (lambda (x) (p (car a) x)) (cdr a)))) (append (sort (cadr p*)) (list (car a)) (sort (car p*))))))))) (sort a))) zenlisp-2013.11.22/src/sort/insert.l0000644000175000017500000000066011064427740015757 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Insert a member into an ordered list: ; (require '~nmath) ; (insert < '#4 '(#3 #5)) => '(#3 #4 #5) (define (insert p x a) (letrec ((ins (lambda (a r) (cond ((or (null a) (p x (car a))) (append (reverse (cons x r)) a)) (t (ins (cdr a) (cons (car a) r))))))) (ins a ()))) zenlisp-2013.11.22/src/sort/isort.l0000644000175000017500000000064311064427742015616 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Sort a list using insertion sort: ; (require '~nmath) ; (isort > '(#1 #3 #0 #2 #4)) => '(#4 #3 #2 #1 #0) (require 'insert) (define (isort p a) (Letrec ((sort (lambda (a r) (cond ((null a) r) (t (sort (cdr a) (insert p (car a) r))))))) (sort a ()))) zenlisp-2013.11.22/src/sort/orderedp.l0000644000175000017500000000071711064427744016266 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Check whether the members of a list ; are in a given monotonic order: ; (require '~nmath) ; (orderedp > '(#9 #8 #7 #6 #5)) => 't (define (orderedp p x) (letrec ((orderedp1 (lambda (x) (cond ((or (null x) (null (cdr x))) :t) (t (and (p (car x) (cadr x)) (orderedp1 (cdr x)))))))) (orderedp1 x))) zenlisp-2013.11.22/src/sort/unsort.l0000644000175000017500000000165611064427750016014 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Generate some entropy by un-sorting a list of ; natural numbers: ; (require '~iota) ; (unsort (iota '#1 '#10) '#4) => '(#1 #3 #10 #2 #6 #9 #8 #4 #7 #5) (require '~nmath) (require 'nth) (define (unsort a seed) (letrec ((remove-nth (lambda (a n r) (cond ((zero n) (cond ((null a) (reverse r)) (t (append (cdr a) (reverse r))))) (t (remove-nth (cdr a) (- n '#1) (cons (car a) r)))))) (unsort4 (lambda (a n k r) (cond ((zero k) (cons (car a) r)) (t (unsort4 (remove-nth a n ()) (remainder (car a) k) (- k '#1) (cons (car (nth n a)) r))))))) (unsort4 a seed (- (length a) '#1) ()))) zenlisp-2013.11.22/src/compilers/0000755000175000017500000000000012243670070015276 5ustar barakbarakzenlisp-2013.11.22/src/compilers/infix.l0000644000175000017500000000751111064427632016600 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Convert arithmetic expressions from prefix to ; infix notation: ; (prefix->infix '(+ '#+2 (* '#+3 (expt '#+4 (+ '#+5 '#+6))))) ; => '#2+3*4^[5+6] ; Prefix expressions may contain variables ; (single-char symbols like X), numbers (like '#57), ; and these functions: +, - (unary or binary), *, /, ; EXPT. PREFIX->INFIX will insert parentheses ; ([ and ]) where necessary. (define (prefix->infix x) (letrec ((ops '((+ . +) (- . -) (* . *) (/ . /) (expt . ^))) (left '#+-*/) (precedence '(high ([]) (expt) (* /) (+ -) low)) (function-p (lambda (x) (and (memq x '(+ - * / expt)) :t))) (left-assoc-p (lambda (x) (and (memq x left)))) (symbol-p (lambda (x) (and (memq x '#abcdefghijklmnopqrstuvwxyz) :t))) (numeric-p (lambda (x) (and (not (atom x)) (eq (car x) 'quote)))) (atomic-p (lambda (x) (or (function-p x) (symbol-p x) (numeric-p x)))) (unary-p (lambda (x) (and (not (null (cdr x))) (null (cddr x))))) (higher-prec-p (lambda (x y) (letrec ((hpp (lambda (x y prec) (cond ((atom prec) :f) ((memq x (car prec)) (not (memq y (car prec)))) ((memq y (car prec)) :f) (t (hpp x y (cdr prec))))))) (cond ((atomic-p x) (not (atomic-p y))) ((atomic-p y) :f) ((unary-p x) (not (unary-p y))) ((unary-p y) :f) (t (hpp (car x) (car y) (cdr precedence))))))) (paren (lambda (x) (cond ((atomic-p x) x) (t (list '[] x))))) (add-parens (lambda (x) (cond ((atomic-p x) x) (t (let ((x (map add-parens x))) (cond ((unary-p x) (cond ((atomic-p (cadr x)) x) ((unary-p (cadr x)) x) (t (list (car x) (paren (cadr x)))))) ((left-assoc-p (car x)) (list (car x) (cond ((higher-prec-p x (cadr x)) (paren (cadr x))) (t (cadr x))) (cond ((higher-prec-p (caddr x) x) (caddr x)) (t (paren (caddr x)))))) (t (list (car x) (cond ((higher-prec-p (cadr x) x) (cadr x)) (t (paren (cadr x)))) (cond ((higher-prec-p x (caddr x)) (paren (caddr x))) (t (caddr x))))))))))) (infix (lambda (x) (cond ((numeric-p x) (cadr x)) ((symbol-p x) (list x)) ((and (eq (car x) '-) (not (atom (cdr x))) (null (cddr x))) (append '#- (infix (cadr x)))) ((and (eq (car x) '[]) (not (atom (cdr x))) (null (cddr x))) (append '#[ (infix (cadr x)) '#])) ((and (not (atom x)) (not (atom (cdr x))) (not (atom (cddr x))) (null (cdddr x)) (function-p (car x))) (append (infix (cadr x)) (list (cdr (assq (car x) ops))) (infix (caddr x)))) (t (bottom (list 'syntax 'error: x))))))) (infix (add-parens x)))) zenlisp-2013.11.22/src/compilers/prefix.l0000644000175000017500000000760711066116502016757 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Convert arithmetic expressions in infix notation ; to S-expressions: ; (infix->prefix '#12+34*56^[7+8]) ; => '(+ '#12 (* '#34 (expt '#56 (+ '#7 '#8)))) ; Infix expressions are represented by flat lists of ; variables (atoms) operators (atoms) and zenlisp-style ; numbers (eg #5). ; The following operators are recognized: +, - (both ; unary and binary), *, /, ^. Brackets ([, ]) are ; recoginzed as parentheses. XX is equal to X*X if ; X is a symbol. (require '~rmath) (define (infix->prefix x) (letrec ((symbol-p (lambda (x) (and (memq x '#abcdefghijklmnopqrstuvwxyz) :t))) (number (lambda (x r) (cond ((or (null x) (not (digitp (car x)))) (list (list 'quote (reverse r)) x)) (t (number (cdr x) (cons (car x) r)))))) (symbol (lambda (x) (list (car x) (cdr x)))) (expr car) (rest cadr) (car-of-rest caadr) (cdr-of-rest cdadr) ; factor := [ sum ] ; | - factor ; | Number ; | Symbol (factor (lambda (x) (cond ((null x) (bottom 'syntax 'error 'at: x)) ((eq (car x) '[) (let ((xsub (sum (cdr x)))) (cond ((null (rest xsub)) (bottom 'missing-right-paren)) ((eq (car-of-rest xsub) ']) (list (expr xsub) (cdr-of-rest xsub))) (t (bottom 'missing-right-paren))))) ((eq (car x) '-) (let ((fac (factor (cdr x)))) (list (list '- (expr fac)) (rest fac)))) ((digitp (car x)) (number x ())) ((symbol-p (car x)) (symbol x)) (t (bottom 'syntax 'error 'at: x))))) ; power := factor ; | factor ^ power (power (lambda (x) (let ((left (factor x))) (cond ((null (rest left)) left) ((eq (car-of-rest left) '^) (let ((right (power (cdr-of-rest left)))) (list (list 'expt (expr left) (expr right)) (rest right)))) (t left))))) ; term := power ; | power Symbol ; | power * term ; | power / term (term2 (lambda (out in) (cond ((null in) (list out in)) ((symbol-p (car in)) (let ((right (power in))) (term2 (list '* out (expr right)) (rest right)))) ((eq (car in) '*) (let ((right (power (cdr in)))) (term2 (list '* out (expr right)) (rest right)))) ((eq (car in) '/) (let ((right (power (cdr in)))) (term2 (list '/ out (expr right)) (rest right)))) (t (list out in))))) (term (lambda (x) (let ((left (power x))) (term2 (expr left) (rest left))))) ; sum := term ; | term + sum ; | term - sum (sum2 (lambda (out in) (cond ((null in) (list out in)) ((eq (car in) '+) (let ((right (term (cdr in)))) (sum2 (list '+ out (expr right)) (rest right)))) ((eq (car in) '-) (let ((right (term (cdr in)))) (sum2 (list '- out (expr right)) (rest right)))) (t (list out in))))) (sum (lambda (x) (let ((left (term x))) (sum2 (expr left) (rest left)))))) (let ((px (sum x))) (cond ((not (null (rest px))) (bottom (list 'syntax 'error 'at: (cadr px)))) (t (expr px)))))) zenlisp-2013.11.22/src/compilers/prolog-db.l0000644000175000017500000000310411064427640017341 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. (define *database* '( ((female cathy)) ((female denise)) ((male eric)) ((female fanny)) ((parent bertram eric)) ; Parent relationship facts ((parent cathy eric)) ((parent anthony cathy)) ((parent eric denise)) ((parent anthony fanny)) ((mother (? a) (? b)) ; A is mother of B if (female (? a)) ; A is female and (parent (? a) (? b))) ; A is parent of B ((father (? a) (? b)) ; A is father of B if (male (? a)) ; A is male and (parent (? a) (? b))) ; A is parent of B ((wife (? a) (? b)) ; A is (often) wife of B if (mother (? a) (? x)) ; A is mother of X and (father (? b) (? x))) ; B is father of X ((child (? a) (? b)) ; A is child of B if (parent (? b) (? a))) ; B is parent of A ((descendant (? a) (? b)) ; A is descendant of B if (child (? a) (? b))) ; A is child of B ((descendant (? a) (? b)) ; or if (child (? a) (? x)) ; A is child of X and (descendant (? x) (? b))) ; X is descendant of B )) ; Sample queries: ; Make the output of QUERY visible: ; (trace print) ; (query '(father anthony (? child))) ; whose father is Anthony? ; (query '(parent (? parent) eric)) ; who are Eric's parents? ; (query '(descendant (? descendant) bertram)) ; list descendants of Bertram. ; (query '(wife (? wife) (? husband))) ; who is who's wife? ; (query '((? relation) cathy (? person))) ; which relations does Cathy have? zenlisp-2013.11.22/src/compilers/prolog.l0000644000175000017500000000537411064427640016771 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; A simple PROLOG interpreter. ; This program is heavily based on a tiny PROLOG ; interpreter written in MACLISP by Ken Kahn. (define (prolog q db) (letrec ((variable-p (lambda (x) (and (not (atom x)) (eq (car x) '?)))) (new-scope (lambda (env ident) (cond ((atom env) env) ((variable-p env) (append env ident)) (t (cons (new-scope (car env) ident) (new-scope (cdr env) ident)))))) (new-env-id (lambda (x) (list (cons 'i (car x))))) (value-of (lambda (x env) (cond ((variable-p x) (let ((v (assoc x env))) (cond (v (value-of (cdr v) env)) (t x)))) (t x)))) (unify (lambda (x y env) (let ((x (value-of x env)) (y (value-of y env))) (cond ((variable-p x) (cons (cons x y) env)) ((variable-p y) (cons (cons y x) env)) ((atom x) (cond ((eq x y) env) (t ()))) ((atom y) (cond ((eq x y) env) (t ()))) (t (let ((new (unify (car x) (car y) env))) (cond ((null new) ()) (t (unify (cdr x) (cdr y) new))))))))) (try-rules (lambda (rules goals env ident result) (cond ((null rules) result) (t (let ((thisrule (new-scope (car rules) ident))) (let ((newenv (unify (car goals) (car thisrule) env))) (cond ((null newenv) (try-rules (cdr rules) goals env ident result)) (t (let ((res (prove (append (cdr thisrule) (cdr goals)) newenv (new-env-id ident)))) (try-rules (cdr rules) goals env ident (append result res))))))))))) (list-env (lambda (env) (letrec ((ls-env (lambda (e res) (cond ((null (cdr e)) (list res)) ((null (caddr (caar e))) (ls-env (cdr e) (cons (cons (cadr (caar e)) (value-of (caar e) env)) res))) (t (ls-env (cdr e) res)))))) (ls-env env ())))) (prove (lambda (goals env ident) (cond ((null goals) (list-env env)) (t (try-rules db goals env ident ())))))) (prove (list (new-scope q '(()))) '((())) '((i))))) zenlisp-2013.11.22/src/compilers/zeval.l0000644000175000017500000002152011064427644016603 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Evaluate a pure LISP expression in a given environment: ; (zeval '(letrec ((foo ; (lambda (x) ; (cond ((eq x ()) 'foo) ; (t (foo (cdr x))))))) ; (foo '#xxxxx)) ()) ; => 'foo ; ; This is basically an interpreter for zenlisp modulo DEFINE. ; Yes, it is lexically scoped and tail-recursive. (define (zeval x e) (letrec ((initial-env (list (cons 'closure 'closure) (cons 't ':t) (cons ':t ':t) (cons ':f ':f) (cons 'and '(%special . and)) (cons 'apply '(%special . apply)) (cons 'cond '(%special . cond)) (cons 'eval '(%special . eval)) (cons 'lambda '(%special . lambda)) (cons 'let '(%special . let)) (cons 'letrec '(%special . letrec)) (cons 'or '(%special . or)) (cons 'quote '(%special . quote)) (cons 'atom (cons '%primitive atom)) (cons 'bottom (cons '%primitive bottom)) (cons 'car (cons '%primitive car)) (cons 'cdr (cons '%primitive cdr)) (cons 'cons (cons '%primitive cons)) (cons 'defined (cons '%primitive defined)) (cons 'eq (cons '%primitive eq)) (cons 'explode (cons '%primitive explode)) (cons 'implode (cons '%primitive implode)) (cons 'recursive-bind (cons '%primitive recursive-bind)))) (value-of (lambda (x e) (let ((v (assq x e))) (cond ((or (not v) (eq (cdr v) '%void)) (bottom 'undefined: x)) (t (cdr v)))))) (ev-list (lambda (x e) (cond ((null x) ()) ((atom x) (bottom 'improper-list-in-application: x)) (t (cons (ev (car x) e) (ev-list (cdr x) e)))))) (check-args (lambda (a n more) (cond ((null n) (or more (null a))) ((null a) :f) (t (check-args (cdr a) (cdr n) more))))) (wrong-args (lambda (name args) (bottom 'wrong-number-of-arguments: (cons name args)))) (args-ok (lambda (name a n more) (cond ((check-args a n more) :t) (t (wrong-args name a))))) (eval-until (lambda (t/f a e) (cond ((null (cdr a)) (car a)) ((atom a) (bottom 'improper-list-in-and/or: a)) (t (let ((v (ev (car a) e))) (cond ((eq (not v) (not t/f)) (list 'quote v)) (t (eval-until t/f (cdr a) e)))))))) (do-and (lambda (a e) (cond ((null a) :t) (t (eval-until :f a e))))) (clause-p (lambda (x) (and (not (atom x)) (not (atom (cdr x))) (null (cddr x))))) (do-cond (lambda (a e) (cond ((null a) (bottom 'no-default-in-cond)) ((atom a) (bottom 'improper-list-in-cond)) ((not (clause-p (car a))) (bottom 'bad-clause-in-cond: (car a))) (t (let ((v (ev (caar a) e))) (cond (v (cadar a)) (t (do-cond (cdr a) e)))))))) (do-eval (lambda (args e) (and (args-ok 'eval args '#i :f) (ev (car args) e)))) (lambda-args (lambda (a) (cond ((null a) ()) ((atom a) (list a)) (t (cons (car a) (lambda-args (cdr a))))))) (add-free-var (lambda (fenv var e) (cond ((assq var fenv) fenv) (t (let ((v (assq var e))) (cond (v (cons v fenv)) (t (cons (cons var '%void) fenv)))))))) (capture (lambda (bound x e) (letrec ((collect (lambda (x free) (cond ((null x) free) ((atom x) (cond ((memq x bound) free) (t (add-free-var free x e)))) (t (collect (car x) (collect (cdr x) free))))))) (collect x ())))) (do-lambda (lambda (args e) (and (args-ok 'lambda args '#ii :f) (list 'closure (car args) (cadr args) (capture (lambda-args (car args)) (cadr args) e))))) (do-or (lambda (a e) (cond ((null a) :f) (t (eval-until :t a e))))) (do-quote (lambda (args) (and (args-ok 'quote args '#i :f) (car args)))) (make-env (lambda (fa aa) (cond ((null fa) (cond ((null aa) ()) (t (bottom 'too-many-arguments)))) ((atom fa) (list (cons fa aa))) ((null aa) (bottom 'too-few-arguments)) (t (cons (cons (car fa) (car aa)) (make-env (cdr fa) (cdr aa))))))) (beta (lambda (expr fa aa lex-env e le fix) (ev2 expr e (append (fix (make-env fa aa)) lex-env le)))) (binding-p (lambda (x) (clause-p x))) (do-let/rec (lambda (args e le fix) (cond ((not (args-ok 'let/letrec args '#ii :f)) :f) ((not (apply and (map binding-p (car args)))) (bottom 'bad-let/letrec-syntax: (car args))) (t (let ((formals (map car (car args))) (actuals (map cadr (car args)))) (beta (cadr args) formals (ev-list actuals le) () e le fix)))))) (apply-fn (lambda (fn args e le) (cond ((eq (car fn) '%primitive) (apply (cdr fn) args)) ((eq (car fn) '%special) (apply-special (cdr fn) args e le)) ((eq (car fn) 'closure) (beta (caddr fn) (cadr fn) args (cadddr fn) e le id)) (t (bottom 'application-of-non-function: fn))))) (make-args (lambda (a) (cond ((null (cdr a)) (cond ((atom (car a)) (bottom 'improper-argument-list: (car a))) (t (car a)))) (t (cons (car a) (make-args (cdr a))))))) (apply-special (lambda (fn args e le) (cond ((eq fn 'and) (ev2 (do-and args le) e le)) ((eq fn 'apply) (let ((args (ev-list args le))) (and (args-ok 'apply args '#ii :t) (apply-fn (car args) (make-args (cdr args)) e e)))) ((eq fn 'cond) (ev2 (do-cond args le) e le)) ((eq fn 'eval) (ev2 (do-eval args le) e le)) ((eq fn 'lambda) (do-lambda args le)) ((eq fn 'let) (do-let/rec args e le id)) ((eq fn 'letrec) (do-let/rec args e le recursive-bind)) ((eq fn 'or) (ev2 (do-or args le) e le)) ((eq fn 'quote) (do-quote args)) (t (bottom 'internal:bad-special-operator: fn))))) (function-p (lambda (x) (or (eq (car x) '%primitive) (eq (car x) 'closure)))) (special-p (lambda (x) (eq (car x) '%special))) (ev2 (lambda (x e le) (cond ((null x) ()) ((atom x) (value-of x le)) (t (let ((f (ev (car x) le))) (cond ((eq f 'closure) x) ((atom f) (bottom 'application-of-non-function: f)) (t (let ((args (cond ((function-p f) (ev-list (cdr x) le)) (t (cdr x)))) (new-e (cond ((special-p f) le) (t e)))) (apply-fn f args e new-e))))))))) (ev (lambda (x e) (ev2 x e e)))) (ev x (append e initial-env)))) zenlisp-2013.11.22/src/compilers/lv-rename.l0000644000175000017500000000415611064427634017355 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Rename variables of lambda expressions ; (perform alpha convfersion): ; (lambda-rename '(lambda (x) (lambda (x) x))) ; => (lambda (x:0) (lambda (x:1) x:1)) (require '~nmath) (define (map-car-i f a) (cond ((null a) ()) ((atom a) (f a)) (t (cons (f (car a)) (map-car-i f (cdr a)))))) (define (lambda-rename expr) (letrec ((add (lambda (name level) (implode (append (explode name) '#: level)))) (ext-env (lambda (env vars level) (cond ((null vars) env) ((atom vars) (cons (cons vars (add vars level)) env)) (t (ext-env (cons (cons (car vars) (add (car vars) level)) env) (cdr vars) level))))) (envst (lambda (name env) (let ((v (assq name env))) (cond (v (cdr v)) (t name))))) (rename-vars (lambda (expr env level) (cond ((atom expr) (envst expr env)) ((eq (car expr) 'quote) expr) ((eq (car expr) 'lambda) (let ((args (cadr expr)) (body (caddr expr))) (let ((new-env (ext-env env args level))) (list 'lambda (rename-vars args new-env level) (rename-vars body new-env (+ '#1 level)))))) (t (map-car-i (lambda (x) (rename-vars x env level)) expr)))))) (rename-vars expr () '#0))) (define (subst name sub) (let ((v (assq name sub))) (cond (v (cdr v)) (t name)))) (define (subst-vars expr sub) (cond ((atom expr) (subst expr sub)) ((eq (car expr) 'quote) expr) (t (map-car-i (lambda (x) (subst-vars x sub)) expr)))) (define (beta-reduce app) (let ((app (lambda-rename app))) (let ((vars (cadar app)) (args (cdr app)) (body (caddar app))) (subst-vars body (map cons vars args))))) zenlisp-2013.11.22/src/compilers/unlet.l0000644000175000017500000000142411064427642016610 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 1998-2007 ; See the file LICENSE for conditions of use. ; Convert LET to LAMBDA. ; (unlet '(let ((x '(a.b))) (cdr x))) => '((lambda (x) (cdr x)) '(a.b)) (define (unlet x) (letrec ((make-lambda (lambda (let-expr) (let ((env (cadr let-expr))) (let ((formals (map car env)) (actuals (map (lambda (x) (unlet (cadr x))) env)) (body (unlet (caddr let-expr)))) (append (list (list 'lambda formals body)) actuals)))))) (cond ((atom x) x) ((eq (car x) 'quote) x) ((eq (car x) 'let) (make-lambda x)) ((eq (car x) 'lambda) ; handle dotted formals (list 'lambda (cadr x) (unlet (caddr x)))) (t (map unlet x))))) zenlisp-2013.11.22/src/compilers/regex.l0000644000175000017500000001332611066117706016576 0ustar barakbarak; zenlisp example program ; By Nils M Holm, 2007 ; See the file LICENSE for conditions of use. ; Compile and match regular expressions of the following form: ; _ match any character ; [char...] match character class (may contain ranges like c1-c2) ; ^ match beginning of line ; $ match end of line ; * match zero or more instances of the preceding pattern ; + match one or more instances of the preceding pattern ; ? match the preceding pattern optionally ; \c match c, even if it is special ; ; (re-match (re-compile '#[a-z]*) '#12test34) => '#test ; (re-match (re-compile '#^[a-z]*$) '#12test34) => :f ; __ means not a valid symbol (define character-set '(__ ! " __ $ % & __ __ __ * + , - __ / 0 1 2 3 4 5 6 7 8 9 : __ < = > ? @ a b c d e f g h i j k l m n o p q r s t u v w x y z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t u v w x y z __ | __ ~ __)) (define (pair-p x) (not (atom x))) (define (before-p c0 c1) (letrec ((lt (lambda (set) (cond ((null set) (bottom (list before-b c0 c1))) ((eq c1 (car set)) :f) ((eq c0 (car set)) :t) (t (lt (cdr set))))))) (lt character-set))) (define (make-range c0 cn cls) (letrec ((make (lambda (c cls) (cond ((null c) (bottom 'invalid-symbol-code cn)) ((eq (car c) cn) (cons (car c) cls)) (t (make (cdr c) (cons (car c) cls))))))) (let ((c (memq c0 character-set))) (cond (c (make c cls)) (t (bottom 'invalid-symbol-code c0)))))) (define (compile-class in out cls first) (cond ((null in) :f) ((eq '] (car in)) (list (cdr in) (cons (reverse cls) out))) ((and first (eq '^ (car in))) (compile-class (cdr in) out '#] :f)) ((and (not first) (not (null (cdr cls))) (eq '- (car in)) (pair-p (cdr in)) (not (eq '] (cadr in)))) (let ((c0 (car cls)) (cn (cadr in))) (cond ((before-p c0 cn) (compile-class (cddr in) out (make-range c0 cn (cdr cls)) :f)) (t (compile-class (cdr in) out (cons '- cls) :f))))) (t (compile-class (cdr in) out (cons (car in) cls) :f)))) (define (re-compile re) (letrec ((compile (lambda (in out) (cond ((not in) :f) ((null in) (reverse out)) (t (cond ((eq (car in) '\) (cond ((pair-p (cdr in)) (compile (cddr in) (cons (cadr in) out))) (t :f))) ((memq (car in) '#^$_) (compile (cdr in) (cons (list (car in)) out))) ((memq (car in) '#*?) (compile (cdr in) (cond ((null out) (cons (car in) out)) (t (cons (list (car in) (car out)) (cdr out)))))) ((eq (car in) '+) (compile (cdr in) (cond ((null out) (cons (car in) out)) (t (cons (list '* (car out)) out))))) ((eq (car in) '[) (apply compile (compile-class (cdr in) out '#[ :t))) (t (compile (cdr in) (cons (car in) out))))))))) (compile re ()))) (define (match-char p c) (cond ((eq '_ p) :t) ((atom p) (eq p c)) ((eq '[ (car p)) (and (memq c (cdr p)) :t)) ((eq '] (car p)) (not (memq c (cdr p)))) (t :f))) (define (make-choices p s m) (cond ((or (null s) (not (match-char (cadar p) (car s)))) (list (list s m))) (t (cons (list s m) (make-choices p (cdr s) (cons (car s) m)))))) (define (match-star cre s m) (letrec ((try-choices (lambda (c*) (cond ((null c*) :f) (t (let ((r (match-cre (cdr cre) (caar c*) (cadar c*)))) (cond (r (append (reverse m) r)) (t (try-choices (cdr c*)))))))))) (try-choices (reverse (make-choices cre s ()))))) (define (match-cre cre s m) (cond ((null cre) (reverse m)) ((null s) (cond ((equal cre '(#$)) (match-cre () () m)) ((and (pair-p (car cre)) (eq '* (caar cre)) (null (cdr cre))) ()) (t :f))) ((pair-p (car cre)) (cond ((eq '* (caar cre)) (match-star cre s m)) ((eq '? (caar cre)) (cond ((match-char (cadar cre) (car s)) (match-cre (cdr cre) (cdr s) (cons (car s) m))) (t (match-cre (cdr cre) s m)))) ((match-char (car cre) (car s)) (match-cre (cdr cre) (cdr s) (cons (car s) m))) (t :f))) ((eq (car cre) (car s)) (match-cre (cdr cre) (cdr s) (cons (car s) m))) (t :f))) (define (try-matches cre s) (cond ((null s) (match-cre cre s ())) (t (let ((r (match-cre cre s ()))) (cond ((or (not r) (null r)) (try-matches cre (cdr s))) (t r)))))) (define (re-match cre s) (cond ((and (pair-p cre) (equal '#^ (car cre))) (match-cre (cdr cre) s ())) (t (try-matches cre s)))) zenlisp-2013.11.22/test.l0000644000175000017500000005733711064650214013663 0ustar barakbarak; zenlisp test suite ; By Nils M Holm, 2007, 2008 ; Feel free to copy, share, and modify this code. ; See the file LICENSE for details. ; Run: ./zenlisp -i _test ; diff test.OK _test (load base) (load rmath) '-----core-test----- '(and) (and) '(and :f) (and :f) '(and t) (and t) '(and 'foo) (and 'foo) '(and '(a)) (and '(a)) '(and '(a.b)) (and '(a.b)) '(and '#abc) (and '#abc) '(and :f 'foo) (and :f 'foo) '(and 'foo 'bar 'baz) (and 'foo 'bar 'baz) '(and t t t :f) (and t t t :f) '(apply cons '(a b)) (apply cons '(a b)) '(apply apply (cons cons '((a b)))) (apply apply (cons cons '((a b)))) '(apply cons 'foo) (apply cons 'foo) '(apply 'foo '(x y z)) (apply 'foo '(x y z)) '(atom 'a) (atom 'a) '(atom ()) (atom ()) '(atom '(a)) (atom '(a)) '(atom '(a.b)) (atom '(a.b)) '(atom '(a b c)) (atom '(a b c)) '(bottom) (bottom) '(bottom 'a) (bottom 'a) '(bottom 'a ()) (bottom 'a ()) '(bottom 'a () '(a . b)) (bottom 'a () '(a . b)) '(closure-form ()) (closure-form ()) '(closure-form foo) (closure-form foo) '(closure-form env) (closure-form env) '(lambda () foo) (lambda () foo) '(closure-form body) (closure-form body) '(lambda () foo) (lambda () foo) '(closure-form args) (closure-form args) '(lambda () foo) (lambda () foo) '(car 'a) (car 'a) '(car '(a)) (car '(a)) '(car '(a.b)) (car '(a.b)) '(car '(a b c)) (car '(a b c)) '(car ()) (car ()) '(cdr 'a) (cdr 'a) '(cdr '(a)) (cdr '(a)) '(cdr '(a.b)) (cdr '(a.b)) '(cdr '(a b c)) (cdr '(a b c)) '(cdr ()) (cdr ()) '(cond (t 'foo)) (cond (t 'foo)) '(cond (t 'foo) (t 'bar)) (cond (t 'foo) (t 'bar)) '(cond (:f 'foo) (t 'bar)) (cond (:f 'foo) (t 'bar)) '(cond (:f (bottom)) (t 'bar)) (cond (:f (bottom)) (t 'bar)) '(cond (:f (())) (t 'bar)) (cond (:f (())) (t 'bar)) '(cond (:f '1) (:f '2) (t 'bar)) (cond (:f '1) (:f '2) (t 'bar)) '(cond (:f 'foo)) (cond (:f 'foo)) '(cond) (cond) '(cons 'a 'b) (cons 'a 'b) '(cons 'a '(b)) (cons 'a '(b)) '(cons 'a '(b c)) (cons 'a '(b c)) '(cons 'a ()) (cons 'a ()) '(cons () 'a) (cons () 'a) '(cons () ()) (cons () ()) '(cons 'a (cons 'b 'c)) (cons 'a (cons 'b 'c)) '(defined 'xyz) (defined 'xyz) 'xyz xyz '(define xyz 'foo) (define xyz 'foo) '(defined 'xyz) (defined 'xyz) 'xyz xyz '(define (xyz) 'foo) (define (xyz) 'foo) '(defined 'xyz) (defined 'xyz) '(xyz) (xyz) '(define f (lambda () 'foo)) (define f (lambda () 'foo)) '(f) (f) '(define f (lambda (x) x)) (define f (lambda (x) x)) '(f 'foo) (f 'foo) '(define f (lambda (x y) (cons x y))) (define f (lambda (x y) (cons x y))) '(f 'foo 'bar) (f 'foo 'bar) '(define f (lambda (x y z) (cons x (cons y z)))) (define f (lambda (x y z) (cons x (cons y z)))) '(f 'foo 'bar 'baz) (f 'foo 'bar 'baz) '(define f (lambda x x)) (define f (lambda x x)) '(f) (f) '(f 'foo) (f 'foo) '(f 'foo 'bar) (f 'foo 'bar) '(define f (lambda (x . y) y)) (define f (lambda (x . y) y)) '(f) (f) '(f 'foo) (f 'foo) '(f 'foo 'bar) (f 'foo 'bar) '(define (f) 'foo) (define (f) 'foo) '(f) (f) '(define (f x) x) (define (f x) x) '(f 'foo) (f 'foo) '(define (f x y) (cons x y)) (define (f x y) (cons x y)) '(f 'foo 'bar) (f 'foo 'bar) '(define (f x y z) (cons x (cons y z))) (define (f x y z) (cons x (cons y z))) '(f 'foo 'bar 'baz) (f 'foo 'bar 'baz) '(define (f . x) x) (define (f . x) x) '(f) (f) '(f 'foo) (f 'foo) '(f 'foo 'bar) (f 'foo 'bar) '(define (f x . y) y) (define (f x . y) y) '(f) (f) '(f 'foo) (f 'foo) '(f 'foo 'bar) (f 'foo 'bar) '(defined 'defined) (defined 'defined) '(defined 'undefined) (defined 'undefined) '(defined ()) (defined ()) '(defined '(a.b)) (defined '(a.b)) '(defined '(a b)) (defined '(a b)) '(defined '(a b c)) (defined '(a b c)) '(dump-image delete-me) (dump-image delete-me) '(eq 'a 'a) (eq 'a 'a) '(eq 'a 'b) (eq 'a 'b) '(eq () ()) (eq () ()) '(eq 'a ()) (eq 'a ()) '(eq () 'b) (eq () 'b) '(eq 'a '(b)) (eq 'a '(b)) '(eq '(a) 'b) (eq '(a) 'b) '(eq '(a) '(a)) (eq '(a) '(a)) '(eq '(a.b) '(a.b)) (eq '(a.b) '(a.b)) '(eq '(a b c) '(a b c)) (eq '(a b c) '(a b c)) '(explode 'a) (explode 'a) '(explode 'hello-world) (explode 'hello-world) '(explode ()) (explode ()) '(explode '#abcdef) (explode '#abcdef) '(eval '(cons 'a 'b)) (eval '(cons 'a 'b)) '(define (f x) 'done) (define (f x) 'done) '(f (gc)) (f (gc)) '(implode '(x)) (implode '(x)) '(implode '#hello-world) (implode '#hello-world) '(implode '(a b c (d.e) f)) (implode '(a b c (d.e) f)) '(implode '(a b c de f)) (implode '(a b c de f)) '(lambda () 'foo) (lambda () 'foo) '(lambda (x) x) (lambda (x) x) '(lambda (x y) (cons x y)) (lambda (x y) (cons x y)) '(lambda x x) (lambda x x) '(lambda (x . y) y) (lambda (x . y) y) '(lambda (x y . z) z) (lambda (x y . z) z) '((lambda () 'foo)) ((lambda () 'foo)) '((lambda () 'foo) 'bar) ((lambda () 'foo) 'bar) '((lambda (x) x)) ((lambda (x) x)) '((lambda (x) x) 'foo) ((lambda (x) x) 'foo) '((lambda (x) x) 'foo 'bar) ((lambda (x) x) 'foo 'bar) '((lambda (x y) (cons x y))) ((lambda (x y) (cons x y))) '((lambda (x y) (cons x y)) 'foo) ((lambda (x y) (cons x y)) 'foo) '((lambda (x y) (cons x y)) 'foo 'bar) ((lambda (x y) (cons x y)) 'foo 'bar) '((lambda (x y) (cons x y)) 'foo 'bar 'baz) ((lambda (x y) (cons x y)) 'foo 'bar 'baz) '((lambda x x)) ((lambda x x)) '((lambda x x) 'x) ((lambda x x) 'x) '((lambda x x) 'x 'y) ((lambda x x) 'x 'y) '((lambda x x) 'x 'y 'z) ((lambda x x) 'x 'y 'z) '((lambda (x . y) y) 'x) ((lambda (x . y) y) 'x) '((lambda (x . y) y) 'x 'y) ((lambda (x . y) y) 'x 'y) '((lambda (x . y) y) 'x 'y 'z) ((lambda (x . y) y) 'x 'y 'z) '((lambda (x y . z) z) 'x) ((lambda (x y . z) z) 'x) '((lambda (x y . z) z) 'x 'y) ((lambda (x y . z) z) 'x 'y) '((lambda (x y . z) z) 'x 'y 'z) ((lambda (x y . z) z) 'x 'y 'z) '(define (list . x) x) (define (list . x) x) '(let () ()) (let () ()) '(let ((x 'first)) x) (let ((x 'first)) x) '(let ((x 'first) (y 'second) (z 'third)) (list x y z)) (let ((x 'first) (y 'second) (z 'third)) (list x y z)) '(let (x) x) (let (x) x) '(let x x) (let x x) '(let ((x '0)) (let ((x '1) (y (cons x '5))) y)) (let ((x '0)) (let ((x '1) (y (cons x '5))) y)) '(let ((x '0)) (let ((x '1)) (let ((y (cons x '5))) y))) (let ((x '0)) (let ((x '1)) (let ((y (cons x '5))) y))) '(letrec () ()) (letrec () ()) '(letrec ((x 'first)) x) (letrec ((x 'first)) x) '(letrec ((x 'first) (y 'second) (z 'third)) (list x y z)) (letrec ((x 'first) (y 'second) (z 'third)) (list x y z)) '(letrec (x) x) (letrec (x) x) '(letrec x x) (letrec x x) '(letrec ((even-p (lambda (x) (cond ((eq x ()) t) (t (odd-p (cdr x)))))) (odd-p (lambda (x) (cond ((eq x ()) :f) (t (even-p (cdr x))))))) (list (odd-p '(i i i i i)) (even-p '(i i i i i)))) (letrec ((even-p (lambda (x) (cond ((eq x ()) t) (t (odd-p (cdr x)))))) (odd-p (lambda (x) (cond ((eq x ()) :f) (t (even-p (cdr x))))))) (list (odd-p '(i i i i i)) (even-p '(i i i i i)))) '(defined 'foo) (defined 'foo) '(load foo) (load foo) 'foo foo '(or) (or) '(or :f) (or :f) '(or t) (or t) '(or 'foo) (or 'foo) '(or '(a)) (or '(a)) '(or '(a.b)) (or '(a.b)) '(or '#abc) (or '#abc) '(or :f 'foo) (or :f 'foo) '(or 'foo 'bar 'baz) (or 'foo 'bar 'baz) '(or :f :f :f t) (or :f :f :f t) '(quote foo) (quote foo) '(quote 'foo) (quote 'foo) '(quote (a)) (quote (a)) '(quote (a.b)) (quote (a.b)) '(quote #abcdef) (quote #abcdef) '(quote (define (f x) (cons x ()))) (quote (define (f x) (cons x ()))) '(recursive-bind ()) (recursive-bind ()) '(recursive-bind '((a . b))) (recursive-bind '((a . b))) '(recursive-bind '((f . (closure () (f) ((f . ())))))) (recursive-bind '((f . (closure () (f) ((f . ())))))) '(recursive-bind '((a . (closure () b ((b . ())))) (b . (closure () a ((a . ())))))) (recursive-bind '((a . (closure () b ((b . ())))) (b . (closure () a ((a . ())))))) '(define (d x) (cond ((eq x ()) 'foo) (t (d (cdr x))))) (define (d x) (cond ((eq x ()) 'foo) (t (d (cdr x))))) '(stats ()) (stats ()) '(stats (cons 'foo 'bar)) (stats (cons 'foo 'bar)) '(stats (or 'a 'b 'c 'd 'e 'f)) (stats (or 'a 'b 'c 'd 'e 'f)) '(stats (d '#iiiiiiiiiiiiiiiiiiiiiiiii)) (stats (d '#iiiiiiiiiiiiiiiiiiiiiiiii)) '(trace d) (trace d) '(d '#iiiii) (d '#iiiii) '(trace) (trace) '-----definitions----- (define slist1 '(a b c d e f g h i j)) (define slist2 '(z y x w v u t s r q)) (define nlist '((1 0) (5) (2 5) (1 9) (9) (1 0 1) (7 7) (0) (3 3) (4 5))) (define olist '((0) (5) (9) (1 0) (1 9) (2 5) (3 3) (4 5) (7 7) (1 0 1))) (define ilist '((- 7 7) (- 2 5) (+ 1 0) (+ 5) (+ 1 9) (+ 9) (+ 1 0 1) (+ 0) (+ 3 3) (+ 4 5))) (define rlist '(#7/8 #2/3 #8/9 #5/6 #1/2 #4/5 #9/10 #6/7 #3/4)) (define set1 slist1) (define set2 '(f g h i j k l m n o p)) (define plist1 '(i ii iii iv v vi vii viii ix x)) (define plist2 '(1 2 3 4 5 6 7 8 9 10)) (define alist '((i.1) (ii.2) (iii.3) (iv.4) (v.5) (vi.6) (vii.7) (viii.8) (ix.9) (x.10))) (define clist1 '(((a b) (c d) e) ((f g) (h i)) ((j k) (l m)) n)) (define clist2 '(((a b) (c d) x) ((f g) (h i)) ((j k) (l m)) n)) (define num1 '(5 5 5 5 5)) (define num2 '(7 7 7)) (define int1 '(+ 5 5 5 5 5)) (define int2 '(+ 7 7 7)) (define int1n '(- 5 5 5 5 5)) (define int2n '(- 7 7 7)) (define rat1 '#17/23) (define rat2 '#23/17) (define rat1n '#-17/23) (define rat2n '#-23/17) (define xlist '(symbol (5 5 5) (list with members) (1 2 3) (car (some expr)))) (define expr '(symbol (5 5 5) ((a.b) (c.d)) (list with members) (1 2 3) (car (some expr)))) '-----base-tests----- '(append slist1 slist2) (append slist1 slist2) '(append slist1 ()) (append slist1 ()) '(append () slist1) (append () slist1) '(append '(foo bar) '(baz)) (append '(foo bar) '(baz)) '(append '#abc '#def '#xyz) (append '#abc '#def '#xyz) '(append () '#foo) (append () '#foo) '(append '#foo ()) (append '#foo ()) '(append '(a) '(b . c)) (append '(a) '(b . c)) '(append '#abc 'd) (append '#abc 'd) '(append () ()) (append () ()) '(append ()) (append ()) '(append) (append) '(assoc 'vii alist) (assoc 'vii alist) '(assoc 'xxx alist) (assoc 'xxx alist) '(assoc 'xxx ()) (assoc 'xxx ()) '(assoc 'b '((a.1) (b.2))) (assoc 'b '((a.1) (b.2))) '(assoc 'x '((x.1) (x.2))) (assoc 'x '((x.1) (x.2))) '(assoc 'q '((x.1) (x.2))) (assoc 'q '((x.1) (x.2))) '(assoc '#foo '((#foo . bar))) (assoc '#foo '((#foo . bar))) '(assq 'b '((a.1) (b.2))) (assq 'b '((a.1) (b.2))) '(assq '#foo '((#foo . bar))) (assq '#foo '((#foo . bar))) ; (caaaar clist1) ; (caaadr clist1) ; (caadar clist1) ; (caaddr clist1) ; (cadaar clist1) ; (cadadr clist1) ; (caddar clist1) ; (cadddr clist1) ; (cdaaar clist1) ; (cdaadr clist1) ; (cdadar clist1) ; (cdaddr clist1) ; (cddaar clist1) ; (cddadr clist1) ; (cdddar clist1) ; (cddddr clist1) '(caaar clist1) (caaar clist1) '(caadr clist1) (caadr clist1) '(cadar clist1) (cadar clist1) '(caddr clist1) (caddr clist1) '(cdaar clist1) (cdaar clist1) '(cdadr clist1) (cdadr clist1) '(cddar clist1) (cddar clist1) '(cdddr clist1) (cdddr clist1) '(caar clist1) (caar clist1) '(cadr clist1) (cadr clist1) '(cdar clist1) (cdar clist1) '(cddr clist1) (cddr clist1) '(equal clist1 clist1) (equal clist1 clist1) '(equal clist1 clist2) (equal clist1 clist2) '(equal () ()) (equal () ()) '(equal '(a.b) '(a.b)) (equal '(a.b) '(a.b)) '(equal '(f (f x y) z) '(f (f x y) z)) (equal '(f (f x y) z) '(f (f x y) z)) '(equal '#abcdef '#abcdef) (equal '#abcdef '#abcdef) '(equal 'foo 'bar) (equal 'foo 'bar) '(equal '(x (y) z) '(x (q) z)) (equal '(x (y) z) '(x (q) z)) '(equal '#xxx '#xxy) (equal '#xxx '#xxy) '(id ()) (id ()) '(id 'foo) (id 'foo) '(id expr) (id expr) '(list) (list) '(list 'foo) (list 'foo) '(list 'a 'b 'c) (list 'a 'b 'c) ''((cons 'a 'b)) '((cons 'a 'b)) '(list (cons 'a 'b)) (list (cons 'a 'b)) '(listp expr) (listp expr) '(listp '(x)) (listp '(x)) '(listp ()) (listp ()) '(listp '(a b c)) (listp '(a b c)) '(listp '#abcdef) (listp '#abcdef) '(listp '(a . b)) (listp '(a . b)) '(listp '(a b . c)) (listp '(a b . c)) '(listp 'foo) (listp 'foo) '(map cons olist olist) (map cons olist olist) '(map car '((a) (b) (c))) (map car '((a) (b) (c))) '(map cdr '((a) (b) (c))) (map cdr '((a) (b) (c))) '(map cons '(a b c) '(d e f)) (map cons '(a b c) '(d e f)) '(map list '(a b) '(c d) '(e f)) (map list '(a b) '(c d) '(e f)) '(member '(iv.4) alist) (member '(iv.4) alist) '(member '(iv.5) alist) (member '(iv.5) alist) '(member '(iv.4) ()) (member '(iv.4) ()) '(member 'bar '(foo bar baz)) (member 'bar '(foo bar baz)) '(member '(b.2) '((a.1) (b.2))) (member '(b.2) '((a.1) (b.2))) '(member 'foo '(a b c d e f)) (member 'foo '(a b c d e f)) '(memq 'h slist1) (memq 'h slist1) '(memq 'x slist1) (memq 'x slist1) '(memq 'a ()) (memq 'a ()) '(memq 'bar '(foo bar baz)) (memq 'bar '(foo bar baz)) '(memq '(b.2) '((a.1) (b.2))) (memq '(b.2) '((a.1) (b.2))) '(neq 'foo 'bar) (neq 'foo 'bar) '(neq 'foo '#foo) (neq 'foo '#foo) '(neq 'a '(a.b)) (neq 'a '(a.b)) '(neq 'foo 'foo) (neq 'foo 'foo) '(neq neq neq) (neq neq neq) '(neq () ()) (neq () ()) '(neq '#foo '#foo) (neq '#foo '#foo) '(neq '(a.b) '(a.b)) (neq '(a.b) '(a.b)) '(null ()) (null ()) '(null :f) (null :f) '(null 'x) (null 'x) '(null '(a b c)) (null '(a b c)) '(not ()) (not ()) '(not :f) (not :f) '(not t) (not t) '(not 'foo) (not 'foo) '(not '(a b c)) (not '(a b c)) '(fold cons 'a '(b)) (fold cons 'a '(b)) '(fold cons 'a '(b c)) (fold cons 'a '(b c)) '(fold cons 'a ()) (fold cons 'a ()) '(fold-r cons 'a '(b)) (fold-r cons 'a '(b)) '(fold-r cons 'a '(b c)) (fold-r cons 'a '(b c)) '(fold-r cons 'a ()) (fold-r cons 'a ()) '(reverse clist1) (reverse clist1) '(reverse olist) (reverse olist) '(reverse ()) (reverse ()) '(reverse '(foo bar)) (reverse '(foo bar)) '(reverse '(a b c d e f)) (reverse '(a b c d e f)) '(reverse ()) (reverse ()) '-----numeric-tests----- '(*) (*) '(* '#2) (* '#2) '(* '#2 '#3 '#4 '#5) (* '#2 '#3 '#4 '#5) '(* rat1 rat1) (* rat1 rat1) '(* rat2 rat2n) (* rat2 rat2n) '(* rat1n rat1) (* rat1n rat1) '(* rat2n rat2n) (* rat2n rat2n) '(* int1 int2) (* int1 int2) '(* int1n int2) (* int1n int2) '(* int1 int2n) (* int1 int2n) '(* int1n int2n) (* int1n int2n) '(* num1 num2) (* num1 num2) '(+) (+) '(+ '#2) (+ '#2) '(+ '#2 '#3 '#4 '#5) (+ '#2 '#3 '#4 '#5) '(+ rat1 rat2) (+ rat1 rat2) '(+ rat1 rat2n) (+ rat1 rat2n) '(+ rat1n rat2) (+ rat1n rat2) '(+ rat1n rat2n) (+ rat1n rat2n) '(+ rat2 rat1) (+ rat2 rat1) '(+ rat2 rat1n) (+ rat2 rat1n) '(+ rat2n rat1) (+ rat2n rat1) '(+ rat2n rat1n) (+ rat2n rat1n) '(+ int1 int2) (+ int1 int2) '(+ int1 int2n) (+ int1 int2n) '(+ int1n int2) (+ int1n int2) '(+ int1n int2n) (+ int1n int2n) '(+ num1 num2) (+ num1 num2) '(+ num2 num1) (+ num2 num1) '(- '#2) (- '#2) '(- '#2 '#3 '#4 '#5) (- '#2 '#3 '#4 '#5) '(- rat1 rat2) (- rat1 rat2) '(- rat1 rat2n) (- rat1 rat2n) '(- rat1n rat2) (- rat1n rat2) '(- rat1n rat2n) (- rat1n rat2n) '(- rat2 rat1) (- rat2 rat1) '(- rat2 rat1n) (- rat2 rat1n) '(- rat2n rat1) (- rat2n rat1) '(- rat2n rat1n) (- rat2n rat1n) '(- int1 int2) (- int1 int2) '(- int1 int2n) (- int1 int2n) '(- int1n int2) (- int1n int2) '(- int1n int2n) (- int1n int2n) '(- int2 int1) (- int2 int1) '(- int2 int1n) (- int2 int1n) '(- int2n int1) (- int2n int1) '(- int2n int1n) (- int2n int1n) '(- num1 num2) (- num1 num2) '(- num2 num1) (- num2 num1) '(/ '#2) (/ '#2) '(/ '#2 '#3 '#4 '#5) (/ '#2 '#3 '#4 '#5) '(/ rat1 rat2) (/ rat1 rat2) '(/ rat1 rat2n) (/ rat1 rat2n) '(/ rat1n rat2) (/ rat1n rat2) '(/ rat1n rat2n) (/ rat1n rat2n) '(/ rat2 rat1) (/ rat2 rat1) '(/ rat2 rat1n) (/ rat2 rat1n) '(/ rat2n rat1) (/ rat2n rat1) '(/ rat2n rat1n) (/ rat2n rat1n) '(/ int1 int2) (/ int1 int2) '(/ int1 int2n) (/ int1 int2n) '(/ int1n int2) (/ int1n int2) '(/ int1n int2n) (/ int1n int2n) '(/ int2 int1) (/ int2 int1) '(/ int2 int1n) (/ int2 int1n) '(/ int2n int1) (/ int2n int1) '(/ int2n int1n) (/ int2n int1n) '(/ num1 num2) (/ num1 num2) '(/ num2 num1) (/ num2 num1) '(< '#2 '#3 '#4 '#5) (< '#2 '#3 '#4 '#5) '(< rat1 rat2) (< rat1 rat2) '(< rat1 rat2n) (< rat1 rat2n) '(< rat1n rat2) (< rat1n rat2) '(< rat1n rat2n) (< rat1n rat2n) '(< rat2 rat1) (< rat2 rat1) '(< rat2 rat1n) (< rat2 rat1n) '(< rat2n rat1) (< rat2n rat1) '(< rat2n rat1n) (< rat2n rat1n) '(< rat2 rat2) (< rat2 rat2) '(< rat2n rat2n) (< rat2n rat2n) '(< int1 int2) (< int1 int2) '(< int2n int1n) (< int2n int1n) '(< num1 num2) (< num1 num2) '(< num2 num1) (< num2 num1) '(<= '#3 '#3 '#4 '#5) (<= '#3 '#3 '#4 '#5) '(<= rat1 rat2) (<= rat1 rat2) '(<= rat1 rat2n) (<= rat1 rat2n) '(<= rat1n rat2) (<= rat1n rat2) '(<= rat1n rat2n) (<= rat1n rat2n) '(<= rat2 rat1) (<= rat2 rat1) '(<= rat2 rat1n) (<= rat2 rat1n) '(<= rat2n rat1) (<= rat2n rat1) '(<= rat2n rat1n) (<= rat2n rat1n) '(<= rat2 rat2) (<= rat2 rat2) '(<= rat2n rat2n) (<= rat2n rat2n) '(<= int1 int2) (<= int1 int2) '(<= int2n int1n) (<= int2n int1n) '(<= num1 num2) (<= num1 num2) '(<= num2 num1) (<= num2 num1) '(= '#3 '#3 '#3 '#3) (= '#3 '#3 '#3 '#3) '(= num1 num1) (= num1 num1) '(= num1 num2) (= num1 num2) '(= int1 int1) (= int1 int1) '(= int1 int1n) (= int1 int1n) '(= int1 int2) (= int1 int2) '(= int1n int1n) (= int1n int1n) '(= int1n int2n) (= int1n int2n) '(= rat1 rat1) (= rat1 rat1) '(= rat1 rat1n) (= rat1 rat1n) '(= rat1 rat2) (= rat1 rat2) '(= rat1n rat1n) (= rat1n rat1n) '(= rat1n rat2n) (= rat1n rat2n) '(= '#2 '#10/5) (= '#2 '#10/5) '(> '#5 '#4 '#3 '#2) (> '#5 '#4 '#3 '#2) '(> rat1 rat2) (> rat1 rat2) '(> rat1 rat2n) (> rat1 rat2n) '(> rat1n rat2) (> rat1n rat2) '(> rat1n rat2n) (> rat1n rat2n) '(> rat2 rat1) (> rat2 rat1) '(> rat2 rat1n) (> rat2 rat1n) '(> rat2n rat1) (> rat2n rat1) '(> rat2n rat1n) (> rat2n rat1n) '(> rat2 rat2) (> rat2 rat2) '(> rat2n rat2n) (> rat2n rat2n) '(> int1 int2) (> int1 int2) '(> int2n int1n) (> int2n int1n) '(> num1 num2) (> num1 num2) '(> num2 num1) (> num2 num1) '(>= '#5 '#4 '#3 '#3) (>= '#5 '#4 '#3 '#3) '(>= rat1 rat2) (>= rat1 rat2) '(>= rat1 rat2n) (>= rat1 rat2n) '(>= rat1n rat2) (>= rat1n rat2) '(>= rat1n rat2n) (>= rat1n rat2n) '(>= rat2 rat1) (>= rat2 rat1) '(>= rat2 rat1n) (>= rat2 rat1n) '(>= rat2n rat1) (>= rat2n rat1) '(>= rat2n rat1n) (>= rat2n rat1n) '(>= rat2 rat2) (>= rat2 rat2) '(>= rat2n rat2n) (>= rat2n rat2n) '(>= int1 int2) (>= int1 int2) '(>= int2n int1n) (>= int2n int1n) '(>= num1 num2) (>= num1 num2) '(>= num2 num1) (>= num2 num1) '(abs num1) (abs num1) '(abs int1) (abs int1) '(abs int1n) (abs int1n) '(abs rat1) (abs rat1) '(abs rat1n) (abs rat1n) '(denominator rat1) (denominator rat1) '(denominator rat2) (denominator rat2) '(denominator rat1n) (denominator rat1n) '(denominator rat2n) (denominator rat2n) '(divide int1 int2) (divide int1 int2) '(divide int1 int2n) (divide int1 int2n) '(divide int1n int2) (divide int1n int2) '(divide int1n int2n) (divide int1n int2n) '(divide int2 int1) (divide int2 int1) '(divide int2 int1n) (divide int2 int1n) '(divide int2n int1) (divide int2n int1) '(divide int2n int1n) (divide int2n int1n) '(divide num1 num2) (divide num1 num2) '(divide num1 int2) (divide num1 int2) '(divide num1 int2n) (divide num1 int2n) '(divide int1n num2) (divide int1n num2) 'digits 0 1 2 3 4 5 6 7 8 9 '(even '#100) (even '#100) '(even '#101) (even '#101) '(even '#-102) (even '#-102) '(even '#-103) (even '#-103) '(even '#104) (even '#104) '(even '#105) (even '#105) '(even '#106) (even '#106) '(even '#-107) (even '#-107) '(even '#-108) (even '#-108) '(even '#-109) (even '#-109) '(even '#2/1) (even '#2/1) '(even '#2/3) (even '#2/3) '(expt '#2 '#0) (expt '#2 '#0) '(expt '#2 '#1) (expt '#2 '#1) '(expt '#2 '#16) (expt '#2 '#8) '(expt '#2 '#-1) (expt '#2 '#-1) '(expt '#2 '#-8) (expt '#2 '#-8) '(expt '#1/2 '#-8) (expt '#1/2 '#-8) '(expt '#2/3 '#-3) (expt '#2/3 '#-3) '(expt '#-2/3 '#3) (expt '#-2/3 '#3) '(expt '#-2/3 '#-3) (expt '#-2/3 '#-3) '(gcd '#289 '#34) (gcd '#289 '#34) '(gcd '#34 '#289) (gcd '#34 '#289) '(gcd '#+289 '#+34) (gcd '#+289 '#+34) '(gcd '#+34 '#+289) (gcd '#+34 '#+289) '(gcd '#-289 '#+34) (gcd '#-289 '#+34) '(gcd '#+34 '#-289) (gcd '#+34 '#-289) '(integer rat1) (integer rat1) '(integer '#20/5) (integer '#20/5) '(integer int1n) (integer int1n) '(integer num1) (integer num1) '(integer int1) (integer int1) '(integer int1n) (integer int1n) '(integer num1) (integer num1) '(integer-p int1) (integer-p int1) '(integer-p int1n) (integer-p int1n) '(integer-p num1) (integer-p num1) '(length clist1) (length clist1) '(length nlist) (length nlist) '(length xlist) (length xlist) '(apply max '(#2/3)) (apply max '(#2/3)) '(apply max rlist) (apply max rlist) '(apply min '(#2/3)) (apply min '(#2/3)) '(apply min rlist) (apply min rlist) '(modulo int1 int2) (modulo int1 int2) '(modulo int1 int2n) (modulo int1 int2n) '(modulo int1n int2) (modulo int1n int2) '(modulo int1n int2n) (modulo int1n int2n) '(modulo int2 int1) (modulo int2 int1) '(modulo int2 int1n) (modulo int2 int1n) '(modulo int2n int1) (modulo int2n int1) '(modulo int2n int1n) (modulo int2n int1n) '(modulo num1 num2) (modulo num1 num2) '(modulo num1 int2) (modulo num1 int2) '(modulo num1 int2n) (modulo num1 int2n) '(modulo int1n num2) (modulo int1n num2) '(natural num1) (natural num1) '(natural int1) (natural int1) '(natural int1n) (natural int1n) '(natural rat1) (natural rat1) '(natural '#20/4) (natural '#20/4) '(natural '#-20/4) (natural '#-20/4) '(natural-p num1) (natural-p num1) '(natural-p int1) (natural-p int1) '(natural-p int1n) (natural-p int1n) '(negate rat1) (negate rat1) '(negate rat1n) (negate rat1n) '(negate int1) (negate int1) '(negate int1n) (negate int1n) '(negate num1) (negate num1) '(negative rat1) (negative rat1) '(negative rat1n) (negative rat1n) '(negative int1) (negative int1) '(negative int1n) (negative int1n) '(negative num1) (negative num1) '(number-p num1) (number-p num1) '(number-p int1) (number-p int1) '(number-p int1n) (number-p int1n) '(number-p rat1) (number-p rat1) '(number-p rat1n) (number-p rat1n) '(number-p '#-1/-1) (number-p '#-1/-1) '(number-p clist1) (number-p clist1) '(numerator rat1) (numerator rat1) '(numerator rat2) (numerator rat2) '(numerator rat1n) (numerator rat1n) '(numerator rat2n) (numerator rat2n) '(odd '#100) (odd '#100) '(odd '#101) (odd '#101) '(odd '#-102) (odd '#-102) '(odd '#-103) (odd '#-103) '(odd '#104) (odd '#104) '(odd '#105) (odd '#105) '(odd '#106) (odd '#106) '(odd '#-107) (odd '#-107) '(odd '#-108) (odd '#-108) '(odd '#-109) (odd '#-109) '(odd '#2/1) (odd '#2/1) '(odd '#2/3) (odd '#2/3) '(one '#0) (one '#0) '(one '#1) (one '#1) '(one '#+1) (one '#+1) '(one '#+25) (one '#+25) '(one '#-1) (one '#-1) '(one rat1) (one rat1) '(one '#1/2) (one '#1/2) '(one '#2/2) (one '#2/2) '(one '#-2/2) (one '#-2/2) '(quotient int1 int2) (quotient int1 int2) '(quotient int1 int2n) (quotient int1 int2n) '(quotient int1n int2) (quotient int1n int2) '(quotient int1n int2n) (quotient int1n int2n) '(quotient int2 int1) (quotient int2 int1) '(quotient int2 int1n) (quotient int2 int1n) '(quotient int2n int1) (quotient int2n int1) '(quotient int2n int1n) (quotient int2n int1n) '(quotient num1 num2) (quotient num1 num2) '(quotient num1 int2) (quotient num1 int2) '(quotient num1 int2n) (quotient num1 int2n) '(quotient int1n num2) (quotient int1n num2) '(rational rat1) (rational rat1) '(rational rat1n) (rational rat1n) '(rational int1) (rational int1) '(rational int1n) (rational int1n) '(rational num1) (rational num1) '(rational-p rat1) (rational-p rat1) '(rational-p rat1n) (rational-p rat1n) '(rational-p int1) (rational-p int1) '(rational-p int1n) (rational-p int1n) '(rational-p num1) (rational-p num1) '(remainder int1 int2) (remainder int1 int2) '(remainder int1 int2n) (remainder int1 int2n) '(remainder int1n int2) (remainder int1n int2) '(remainder int1n int2n) (remainder int1n int2n) '(remainder int2 int1) (remainder int2 int1) '(remainder int2 int1n) (remainder int2 int1n) '(remainder int2n int1) (remainder int2n int1) '(remainder int2n int1n) (remainder int2n int1n) '(remainder num1 num2) (remainder num1 num2) '(remainder num1 int2) (remainder num1 int2) '(remainder num1 int2n) (remainder num1 int2n) '(remainder int1n num2) (remainder int1n num2) '(sqrt '#1) (sqrt '#1) '(sqrt '#100) (sqrt '#100) '(sqrt '#2) (sqrt '#2) '(zero '(0)) (zero '(0)) '(zero '(1)) (zero '(1)) '(zero '(+ 0)) (zero '(+ 0)) '(zero '(- 0)) (zero '(- 0)) '(zero '#2/5) (zero '#2/5) '(zero '#0/5) (zero '#0/5) '(quit) (quit) 'still-here-p zenlisp-2013.11.22/test.OK0000644000175000017500000005022412243656762013743 0ustar barakbarakzenlisp 2013-11-22 by Nils M Holm Warning: no image loaded => :t => :t => '-----core-test----- => '(and) => :t => '(and :f) => :f => '(and t) => :t => '(and 'foo) => 'foo => '(and '#a) => '#a => '(and '(a . b)) => '(a . b) => '(and '#abc) => '#abc => '(and :f 'foo) => :f => '(and 'foo 'bar 'baz) => 'baz => '(and t t t :f) => :f => '(apply cons '#ab) => '(a . b) => '(apply apply (cons cons '(#ab))) => '(a . b) => '(apply cons 'foo) * REPL: apply: improper argument list: foo => '(apply 'foo '#xyz) * REPL: apply: got non-function: foo => '(atom 'a) => :t => '(atom ()) => :t => '(atom '#a) => :f => '(atom '(a . b)) => :f => '(atom '#abc) => :f => '(bottom) * REPL: (bottom) => '(bottom 'a) * REPL: (bottom a) => '(bottom 'a ()) * REPL: (bottom a ()) => '(bottom 'a () '(a . b)) * REPL: (bottom a () (a . b)) => '(closure-form ()) * REPL: closure-form: got non-symbol: () => '(closure-form foo) => :f => '(closure-form env) => 'env => '(lambda () foo) => (closure () foo ((foo . {void}))) => '(closure-form body) => 'body => '(lambda () foo) => {closure () foo} => '(closure-form args) => 'args => '(lambda () foo) => {closure ()} => '(car 'a) * REPL: car: cannot split atoms: a => '(car '#a) => 'a => '(car '(a . b)) => 'a => '(car '#abc) => 'a => '(car ()) * REPL: car: cannot split atoms: () => '(cdr 'a) * REPL: cdr: cannot split atoms: a => '(cdr '#a) => () => '(cdr '(a . b)) => 'b => '(cdr '#abc) => '#bc => '(cdr ()) * REPL: cdr: cannot split atoms: () => '(cond (t 'foo)) => 'foo => '(cond (t 'foo) (t 'bar)) => 'foo => '(cond (:f 'foo) (t 'bar)) => 'bar => '(cond (:f (bottom)) (t 'bar)) => 'bar => '(cond (:f (())) (t 'bar)) => 'bar => '(cond (:f '1) (:f '2) (t 'bar)) => 'bar => '(cond (:f 'foo)) * REPL: cond: no default => '(cond) * REPL: wrong argument count: (cond) => '(cons 'a 'b) => '(a . b) => '(cons 'a '#b) => '#ab => '(cons 'a '#bc) => '#abc => '(cons 'a ()) => '#a => '(cons () 'a) => '(() . a) => '(cons () ()) => '(()) => '(cons 'a (cons 'b 'c)) => '(a b . c) => '(defined 'xyz) => :f => 'xyz * REPL: symbol not bound: xyz => '(define xyz 'foo) => 'xyz => '(defined 'xyz) => :t => 'xyz => 'foo => '(define (xyz) 'foo) => 'xyz => '(defined 'xyz) => :t => '(xyz) => 'foo => '(define f (lambda () 'foo)) => 'f => '#f => 'foo => '(define f (lambda #x x)) => 'f => '(f 'foo) => 'foo => '(define f (lambda #xy (cons x y))) => 'f => '(f 'foo 'bar) => '(foo . bar) => '(define f (lambda #xyz (cons x (cons y z)))) => 'f => '(f 'foo 'bar 'baz) => '(foo bar . baz) => '(define f (lambda x x)) => 'f => '#f => () => '(f 'foo) => '(foo) => '(f 'foo 'bar) => '(foo bar) => '(define f (lambda (x . y) y)) => 'f => '#f * REPL: wrong argument count: ({closure (x . y)}) => '(f 'foo) => () => '(f 'foo 'bar) => '(bar) => '(define #f 'foo) => 'f => '#f => 'foo => '(define #fx x) => 'f => '(f 'foo) => 'foo => '(define #fxy (cons x y)) => 'f => '(f 'foo 'bar) => '(foo . bar) => '(define #fxyz (cons x (cons y z))) => 'f => '(f 'foo 'bar 'baz) => '(foo bar . baz) => '(define (f . x) x) => 'f => '#f => () => '(f 'foo) => '(foo) => '(f 'foo 'bar) => '(foo bar) => '(define (f x . y) y) => 'f => '#f * REPL: wrong argument count: ({closure (x . y)}) => '(f 'foo) => () => '(f 'foo 'bar) => '(bar) => '(defined 'defined) => :t => '(defined 'undefined) => :f => '(defined ()) * REPL: defined: got non-symbol: () => '(defined '(a . b)) * REPL: defined: got non-symbol: (a . b) => '(defined '#ab) * REPL: defined: got non-symbol: #ab => '(defined '#abc) * REPL: defined: got non-symbol: #abc => '(dump-image delete-me) => :t => '(eq 'a 'a) => :t => '(eq 'a 'b) => :f => '(eq () ()) => :t => '(eq 'a ()) => :f => '(eq () 'b) => :f => '(eq 'a '#b) => :f => '(eq '#a 'b) => :f => '(eq '#a '#a) => :f => '(eq '(a . b) '(a . b)) => :f => '(eq '#abc '#abc) => :f => '(explode 'a) => '#a => '(explode 'hello-world) => '#hello-world => '(explode ()) => () => '(explode '#abcdef) * REPL: explode: got non-symbol: #abcdef => '(eval '(cons 'a 'b)) => '(a . b) => '(define #fx 'done) => 'f => '(f (gc)) => 'done => '(implode '#x) => 'x => '(implode '#hello-world) => 'hello-world => '(implode '(a b c (d . e) f)) * REPL: implode: non-symbol in argument: (d . e) => '(implode '(a b c de f)) * REPL: implode: input symbol has multiple characters: de => '(lambda () 'foo) => {closure ()} => '(lambda #x x) => {closure #x} => '(lambda #xy (cons x y)) => {closure #xy} => '(lambda x x) => {closure x} => '(lambda (x . y) y) => {closure (x . y)} => '(lambda (x y . z) z) => {closure (x y . z)} => '((lambda () 'foo)) => 'foo => '((lambda () 'foo) 'bar) * REPL: wrong argument count: ({closure ()} bar) => '((lambda #x x)) * REPL: wrong argument count: ({closure #x}) => '((lambda #x x) 'foo) => 'foo => '((lambda #x x) 'foo 'bar) * REPL: wrong argument count: ({closure #x} foo bar) => '((lambda #xy (cons x y))) * REPL: wrong argument count: ({closure #xy}) => '((lambda #xy (cons x y)) 'foo) * REPL: wrong argument count: ({closure #xy} foo) => '((lambda #xy (cons x y)) 'foo 'bar) => '(foo . bar) => '((lambda #xy (cons x y)) 'foo 'bar 'baz) * REPL: wrong argument count: ({closure #xy} foo bar baz) => '((lambda x x)) => () => '((lambda x x) 'x) => '#x => '((lambda x x) 'x 'y) => '#xy => '((lambda x x) 'x 'y 'z) => '#xyz => '((lambda (x . y) y) 'x) => () => '((lambda (x . y) y) 'x 'y) => '#y => '((lambda (x . y) y) 'x 'y 'z) => '#yz => '((lambda (x y . z) z) 'x) * REPL: wrong argument count: ({closure (x y . z)} x) => '((lambda (x y . z) z) 'x 'y) => () => '((lambda (x y . z) z) 'x 'y 'z) => '#z => '(define (list . x) x) => 'list => '(let () ()) => () => '(let ((x 'first)) x) => 'first => '(let ((x 'first) (y 'second) (z 'third)) (list x y z)) => '(first second third) => '(let #x x) * REPL: let/letrec: bad binding: x => '(let x x) * REPL: let/letrec: bad environment: x => '(let ((x '0)) (let ((x '1) (y (cons x '5))) y)) => '(0 . 5) => '(let ((x '0)) (let ((x '1)) (let ((y (cons x '5))) y))) => '(1 . 5) => '(letrec () ()) => () => '(letrec ((x 'first)) x) => 'first => '(letrec ((x 'first) (y 'second) (z 'third)) (list x y z)) => '(first second third) => '(letrec #x x) * REPL: let/letrec: bad binding: x => '(letrec x x) * REPL: let/letrec: bad environment: x => '(letrec ((even-p (lambda #x (cond ((eq x ()) t) (t (odd-p (cdr x)))))) (odd-p (lambda #x (cond ((eq x ()) :f) (t (even-p (cdr x))))))) (list (odd-p '#iiiii) (even-p '#iiiii))) => '(:t :f) => '(defined 'foo) => :f => '(load foo) => :t => 'foo => 'bar => '(or) => :f => '(or :f) => :f => '(or t) => :t => '(or 'foo) => 'foo => '(or '#a) => '#a => '(or '(a . b)) => '(a . b) => '(or '#abc) => '#abc => '(or :f 'foo) => 'foo => '(or 'foo 'bar 'baz) => 'foo => '(or :f :f :f t) => :t => ''foo => 'foo => '''foo => ''foo => ''#a => '#a => ''(a . b) => '(a . b) => ''#abcdef => '#abcdef => ''(define #fx (cons x ())) => '(define #fx (cons x ())) => '(recursive-bind ()) => () => '(recursive-bind '((a . b))) => '((a . b)) => '(recursive-bind '((f . {closure ()}))) => '((f . {closure ()})) => '(recursive-bind '((a . {closure ()}) (b . {closure ()}))) => '((a . {closure ()}) (b . {closure ()})) => '(define #dx (cond ((eq x ()) 'foo) (t (d (cdr x))))) => 'd => '(stats ()) => '(() #1 #5 #0) => '(stats (cons 'foo 'bar)) => '((foo . bar) #6 #29 #0) => '(stats (or 'a 'b 'c 'd 'e 'f)) => '(a #5 #18 #0) => '(stats (d '#iiiiiiiiiiiiiiiiiiiiiiiii)) => '(foo #312 #1,099 #0) => '(trace d) => :t => '(d '#iiiii) + (d #iiiii) + (d #iiii) + (d #iii) + (d #ii) + (d #i) + (d ()) => 'foo => '(trace) => :t => '-----definitions----- => 'slist1 => 'slist2 => 'nlist => 'olist => 'ilist => 'rlist => 'set1 => 'set2 => 'plist1 => 'plist2 => 'alist => 'clist1 => 'clist2 => 'num1 => 'num2 => 'int1 => 'int2 => 'int1n => 'int2n => 'rat1 => 'rat2 => 'rat1n => 'rat2n => 'xlist => 'expr => '-----base-tests----- => '(append slist1 slist2) => '#abcdefghijzyxwvutsrq => '(append slist1 ()) => '#abcdefghij => '(append () slist1) => '#abcdefghij => '(append '(foo bar) '(baz)) => '(foo bar baz) => '(append '#abc '#def '#xyz) => '#abcdefxyz => '(append () '#foo) => '#foo => '(append '#foo ()) => '#foo => '(append '#a '(b . c)) => '(a b . c) => '(append '#abc 'd) => '(a b c . d) => '(append () ()) => () => '(append ()) => () => '(append) => () => '(assoc 'vii alist) => '(vii . 7) => '(assoc 'xxx alist) => :f => '(assoc 'xxx ()) => :f => '(assoc 'b '((a . 1) (b . 2))) => '(b . 2) => '(assoc 'x '((x . 1) (x . 2))) => '(x . 1) => '(assoc 'q '((x . 1) (x . 2))) => :f => '(assoc '#foo '((#foo . bar))) => '(#foo . bar) => '(assq 'b '((a . 1) (b . 2))) => '(b . 2) => '(assq '#foo '((#foo . bar))) => :f => '(caaar clist1) => 'a => '(caadr clist1) => '#fg => '(cadar clist1) => '#cd => '(caddr clist1) => '(#jk #lm) => '(cdaar clist1) => '#b => '(cdadr clist1) => '(#hi) => '(cddar clist1) => '#e => '(cdddr clist1) => '#n => '(caar clist1) => '#ab => '(cadr clist1) => '(#fg #hi) => '(cdar clist1) => '(#cd e) => '(cddr clist1) => '((#jk #lm) n) => '(equal clist1 clist1) => :t => '(equal clist1 clist2) => :f => '(equal () ()) => :t => '(equal '(a . b) '(a . b)) => :t => '(equal '(f #fxy z) '(f #fxy z)) => :t => '(equal '#abcdef '#abcdef) => :t => '(equal 'foo 'bar) => :f => '(equal '(x #y z) '(x #q z)) => :f => '(equal '#xxx '#xxy) => :f => '(id ()) => () => '(id 'foo) => 'foo => '(id expr) => '(symbol #555 ((a . b) (c . d)) (list with members) #123 (car (some expr))) => '(list) => () => '(list 'foo) => '(foo) => '(list 'a 'b 'c) => '#abc => ''((cons 'a 'b)) => '((cons 'a 'b)) => '(list (cons 'a 'b)) => '((a . b)) => '(listp expr) => :t => '(listp '#x) => :t => '(listp ()) => :t => '(listp '#abc) => :t => '(listp '#abcdef) => :t => '(listp '(a . b)) => :f => '(listp '(a b . c)) => :f => '(listp 'foo) => :f => '(map cons olist olist) => '((#0 0) (#5 5) (#9 9) (#10 1 0) (#19 1 9) (#25 2 5) (#33 3 3) (#45 4 5) (#77 7 7) (#101 1 0 1)) => '(map car '(#a #b #c)) => '#abc => '(map cdr '(#a #b #c)) => '(() () ()) => '(map cons '#abc '#def) => '((a . d) (b . e) (c . f)) => '(map list '#ab '#cd '#ef) => '(#ace #bdf) => '(member '(iv . 4) alist) => '((iv . 4) (v . 5) (vi . 6) (vii . 7) (viii . 8) (ix . 9) (x . 10)) => '(member '(iv . 5) alist) => :f => '(member '(iv . 4) ()) => :f => '(member 'bar '(foo bar baz)) => '(bar baz) => '(member '(b . 2) '((a . 1) (b . 2))) => '((b . 2)) => '(member 'foo '#abcdef) => :f => '(memq 'h slist1) => '#hij => '(memq 'x slist1) => :f => '(memq 'a ()) => :f => '(memq 'bar '(foo bar baz)) => '(bar baz) => '(memq '(b . 2) '((a . 1) (b . 2))) => :f => '(neq 'foo 'bar) => :t => '(neq 'foo '#foo) => :t => '(neq 'a '(a . b)) => :t => '(neq 'foo 'foo) => :f => '(neq neq neq) => :f => '(neq () ()) => :f => '(neq '#foo '#foo) => :t => '(neq '(a . b) '(a . b)) => :t => '(null ()) => :t => '(null :f) => :f => '(null 'x) => :f => '(null '#abc) => :f => '(not ()) => :f => '(not :f) => :t => '(not t) => :f => '(not 'foo) => :f => '(not '#abc) => :f => '(fold cons 'a '#b) => '(a . b) => '(fold cons 'a '#bc) => '((a . b) . c) => '(fold cons 'a ()) => 'a => '(fold-r cons 'a '#b) => '(b . a) => '(fold-r cons 'a '#bc) => '(b c . a) => '(fold-r cons 'a ()) => 'a => '(reverse clist1) => '(n (#jk #lm) (#fg #hi) (#ab #cd e)) => '(reverse olist) => '(#101 #77 #45 #33 #25 #19 #10 #9 #5 #0) => '(reverse ()) => () => '(reverse '(foo bar)) => '(bar foo) => '(reverse '#abcdef) => '#fedcba => '(reverse ()) => () => '-----numeric-tests----- => '#* => '#1 => '(* '#2) => '#2 => '(* '#2 '#3 '#4 '#5) => '#120 => '(* rat1 rat1) => '#289/529 => '(* rat2 rat2n) => '#-529/289 => '(* rat1n rat1) => '#-289/529 => '(* rat2n rat2n) => '#529/289 => '(* int1 int2) => '#43166235 => '(* int1n int2) => '#-43166235 => '(* int1 int2n) => '#-43166235 => '(* int1n int2n) => '#43166235 => '(* num1 num2) => '#43166235 => '#+ => '#0 => '(+ '#2) => '#2 => '(+ '#2 '#3 '#4 '#5) => '#14 => '(+ rat1 rat2) => '#818/391 => '(+ rat1 rat2n) => '#-240/391 => '(+ rat1n rat2) => '#240/391 => '(+ rat1n rat2n) => '#-818/391 => '(+ rat2 rat1) => '#818/391 => '(+ rat2 rat1n) => '#240/391 => '(+ rat2n rat1) => '#-240/391 => '(+ rat2n rat1n) => '#-818/391 => '(+ int1 int2) => '#56332 => '(+ int1 int2n) => '#54778 => '(+ int1n int2) => '#-54778 => '(+ int1n int2n) => '#-56332 => '(+ num1 num2) => '#56332 => '(+ num2 num1) => '#56332 => '(- '#2) => '#-2 => '(- '#2 '#3 '#4 '#5) => '#-10 => '(- rat1 rat2) => '#-240/391 => '(- rat1 rat2n) => '#818/391 => '(- rat1n rat2) => '#-818/391 => '(- rat1n rat2n) => '#240/391 => '(- rat2 rat1) => '#240/391 => '(- rat2 rat1n) => '#818/391 => '(- rat2n rat1) => '#-818/391 => '(- rat2n rat1n) => '#-240/391 => '(- int1 int2) => '#54778 => '(- int1 int2n) => '#56332 => '(- int1n int2) => '#-56332 => '(- int1n int2n) => '#-54778 => '(- int2 int1) => '#-54778 => '(- int2 int1n) => '#56332 => '(- int2n int1) => '#-56332 => '(- int2n int1n) => '#54778 => '(- num1 num2) => '#54778 => '(- num2 num1) => '#-54778 => '(/ '#2) => '#1/2 => '(/ '#2 '#3 '#4 '#5) => '#1/30 => '(/ rat1 rat2) => '#289/529 => '(/ rat1 rat2n) => '#-289/529 => '(/ rat1n rat2) => '#-289/529 => '(/ rat1n rat2n) => '#289/529 => '(/ rat2 rat1) => '#529/289 => '(/ rat2 rat1n) => '#-529/289 => '(/ rat2n rat1) => '#-529/289 => '(/ rat2n rat1n) => '#529/289 => '(/ int1 int2) => '#55555/777 => '(/ int1 int2n) => '#-55555/777 => '(/ int1n int2) => '#-55555/777 => '(/ int1n int2n) => '#55555/777 => '(/ int2 int1) => '#777/55555 => '(/ int2 int1n) => '#-777/55555 => '(/ int2n int1) => '#-777/55555 => '(/ int2n int1n) => '#777/55555 => '(/ num1 num2) => '#55555/777 => '(/ num2 num1) => '#777/55555 => '(< '#2 '#3 '#4 '#5) => :t => '(< rat1 rat2) => :t => '(< rat1 rat2n) => :f => '(< rat1n rat2) => :t => '(< rat1n rat2n) => :f => '(< rat2 rat1) => :f => '(< rat2 rat1n) => :f => '(< rat2n rat1) => :t => '(< rat2n rat1n) => :t => '(< rat2 rat2) => :f => '(< rat2n rat2n) => :f => '(< int1 int2) => :f => '(< int2n int1n) => :f => '(< num1 num2) => :f => '(< num2 num1) => :t => '(<= '#3 '#3 '#4 '#5) => :t => '(<= rat1 rat2) => :t => '(<= rat1 rat2n) => :f => '(<= rat1n rat2) => :t => '(<= rat1n rat2n) => :f => '(<= rat2 rat1) => :f => '(<= rat2 rat1n) => :f => '(<= rat2n rat1) => :t => '(<= rat2n rat1n) => :t => '(<= rat2 rat2) => :t => '(<= rat2n rat2n) => :t => '(<= int1 int2) => :f => '(<= int2n int1n) => :f => '(<= num1 num2) => :f => '(<= num2 num1) => :t => '(= '#3 '#3 '#3 '#3) => :t => '(= num1 num1) => :t => '(= num1 num2) => :f => '(= int1 int1) => :t => '(= int1 int1n) => :f => '(= int1 int2) => :f => '(= int1n int1n) => :t => '(= int1n int2n) => :f => '(= rat1 rat1) => :t => '(= rat1 rat1n) => :f => '(= rat1 rat2) => :f => '(= rat1n rat1n) => :t => '(= rat1n rat2n) => :f => '(= '#2 '#10/5) => :t => '(> '#5 '#4 '#3 '#2) => :t => '(> rat1 rat2) => :f => '(> rat1 rat2n) => :t => '(> rat1n rat2) => :f => '(> rat1n rat2n) => :t => '(> rat2 rat1) => :t => '(> rat2 rat1n) => :t => '(> rat2n rat1) => :f => '(> rat2n rat1n) => :f => '(> rat2 rat2) => :f => '(> rat2n rat2n) => :f => '(> int1 int2) => :t => '(> int2n int1n) => :t => '(> num1 num2) => :t => '(> num2 num1) => :f => '(>= '#5 '#4 '#3 '#3) => :t => '(>= rat1 rat2) => :f => '(>= rat1 rat2n) => :t => '(>= rat1n rat2) => :f => '(>= rat1n rat2n) => :t => '(>= rat2 rat1) => :t => '(>= rat2 rat1n) => :t => '(>= rat2n rat1) => :f => '(>= rat2n rat1n) => :f => '(>= rat2 rat2) => :t => '(>= rat2n rat2n) => :t => '(>= int1 int2) => :t => '(>= int2n int1n) => :t => '(>= num1 num2) => :t => '(>= num2 num1) => :f => '(abs num1) => '#55555 => '(abs int1) => '#55555 => '(abs int1n) => '#55555 => '(abs rat1) => '#17/23 => '(abs rat1n) => '#17/23 => '(denominator rat1) => '#23 => '(denominator rat2) => '#17 => '(denominator rat1n) => '#23 => '(denominator rat2n) => '#17 => '(divide int1 int2) => '(#71 #388) => '(divide int1 int2n) => '(#-71 #388) => '(divide int1n int2) => '(#-71 #-388) => '(divide int1n int2n) => '(#71 #-388) => '(divide int2 int1) => '(#0 #777) => '(divide int2 int1n) => '(#0 #777) => '(divide int2n int1) => '(#0 #-777) => '(divide int2n int1n) => '(#0 #-777) => '(divide num1 num2) => '(#71 #388) => '(divide num1 int2) => '(#71 #388) => '(divide num1 int2n) => '(#-71 #388) => '(divide int1n num2) => '(#-71 #-388) => 'digits => '0 => '1 => '2 => '3 => '4 => '5 => '6 => '7 => '8 => '9 => '(even '#100) => :t => '(even '#101) => :f => '(even '#-102) => :t => '(even '#-103) => :f => '(even '#104) => :t => '(even '#105) => :f => '(even '#106) => :t => '(even '#-107) => :f => '(even '#-108) => :t => '(even '#-109) => :f => '(even '#2/1) => :f => '(even '#2/3) => :f => '(expt '#2 '#0) => '#1 => '(expt '#2 '#1) => '#2 => '(expt '#2 '#16) => '#256 => '(expt '#2 '#-1) => '#1/2 => '(expt '#2 '#-8) => '#1/256 => '(expt '#1/2 '#-8) => '#256 => '(expt '#2/3 '#-3) => '#27/8 => '(expt '#-2/3 '#3) => '#-8/27 => '(expt '#-2/3 '#-3) => '#-27/8 => '(gcd '#289 '#34) => '#17 => '(gcd '#34 '#289) => '#17 => '(gcd '#+289 '#+34) => '#17 => '(gcd '#+34 '#+289) => '#17 => '(gcd '#-289 '#+34) => '#17 => '(gcd '#+34 '#-289) => '#17 => '(integer rat1) * integer: (bottom (r-integer #17/23)) => '(integer '#20/5) => '#4 => '(integer int1n) => '#-55555 => '(integer num1) => '#55555 => '(integer int1) => '#55555 => '(integer int1n) => '#-55555 => '(integer num1) => '#55555 => '(integer-p int1) => :t => '(integer-p int1n) => :t => '(integer-p num1) => :t => '(length clist1) => '#4 => '(length nlist) => '#10 => '(length xlist) => '#5 => '(apply max '(#2/3)) => '#2/3 => '(apply max rlist) => '#9/10 => '(apply min '(#2/3)) => '#2/3 => '(apply min rlist) => '#1/2 => '(modulo int1 int2) => '#388 => '(modulo int1 int2n) => '#-389 => '(modulo int1n int2) => '#389 => '(modulo int1n int2n) => '#-388 => '(modulo int2 int1) => '#777 => '(modulo int2 int1n) => '#-54778 => '(modulo int2n int1) => '#54778 => '(modulo int2n int1n) => '#-777 => '(modulo num1 num2) => '#388 => '(modulo num1 int2) => '#388 => '(modulo num1 int2n) => '#-389 => '(modulo int1n num2) => '#389 => '(natural num1) => '#55555 => '(natural int1) => '#55555 => '(natural int1n) * i-natural: (bottom (i-natural #-55555)) => '(natural rat1) * r-integer: (bottom (r-integer #17/23)) * Trace: natural => '(natural '#20/4) => '#5 => '(natural '#-20/4) * i-natural: (bottom (i-natural #-5)) => '(natural-p num1) => :t => '(natural-p int1) => :f => '(natural-p int1n) => :f => '(negate rat1) => '#-17/23 => '(negate rat1n) => '#17/23 => '(negate int1) => '#-55555 => '(negate int1n) => '#55555 => '(negate num1) => '#-55555 => '(negative rat1) => :f => '(negative rat1n) => :t => '(negative int1) => :f => '(negative int1n) => :t => '(negative num1) => :f => '(number-p num1) => :t => '(number-p int1) => :t => '(number-p int1n) => :t => '(number-p rat1) => :t => '(number-p rat1n) => :t => '(number-p '#-1/-1) => :t => '(number-p clist1) => :f => '(numerator rat1) => '#17 => '(numerator rat2) => '#23 => '(numerator rat1n) => '#-17 => '(numerator rat2n) => '#-23 => '(odd '#100) => :f => '(odd '#101) => :t => '(odd '#-102) => :f => '(odd '#-103) => :t => '(odd '#104) => :f => '(odd '#105) => :t => '(odd '#106) => :f => '(odd '#-107) => :t => '(odd '#-108) => :f => '(odd '#-109) => :t => '(odd '#2/1) => :t => '(odd '#2/3) => :t => '(one '#0) => :f => '(one '#1) => :t => '(one '#+1) => :t => '(one '#+25) => :f => '(one '#-1) => :f => '(one rat1) => :f => '(one '#1/2) => :f => '(one '#2/2) => :t => '(one '#-2/2) => :f => '(quotient int1 int2) => '#71 => '(quotient int1 int2n) => '#-71 => '(quotient int1n int2) => '#-71 => '(quotient int1n int2n) => '#71 => '(quotient int2 int1) => '#0 => '(quotient int2 int1n) => '#0 => '(quotient int2n int1) => '#0 => '(quotient int2n int1n) => '#0 => '(quotient num1 num2) => '#71 => '(quotient num1 int2) => '#71 => '(quotient num1 int2n) => '#-71 => '(quotient int1n num2) => '#-71 => '(rational rat1) => '#17/23 => '(rational rat1n) => '#-17/23 => '(rational int1) => '#+55555/1 => '(rational int1n) => '#-55555/1 => '(rational num1) => '#55555/1 => '(rational-p rat1) => :t => '(rational-p rat1n) => :t => '(rational-p int1) => :f => '(rational-p int1n) => :f => '(rational-p num1) => :f => '(remainder int1 int2) => '#388 => '(remainder int1 int2n) => '#388 => '(remainder int1n int2) => '#-388 => '(remainder int1n int2n) => '#-388 => '(remainder int2 int1) => '#777 => '(remainder int2 int1n) => '#777 => '(remainder int2n int1) => '#-777 => '(remainder int2n int1n) => '#-777 => '(remainder num1 num2) => '#388 => '(remainder num1 int2) => '#388 => '(remainder num1 int2n) => '#388 => '(remainder int1n num2) => '#-388 => '(sqrt '#1) => '#1 => '(sqrt '#100) => '#10 => '(sqrt '#2) => '#665857/470832 => '(zero '#0) => :t => '(zero '#1) => :f => '(zero '#+0) => :t => '(zero '#-0) => :t => '(zero '#2/5) => :f => '(zero '#0/5) => :t => '(quit) zenlisp-2013.11.22/Todo0000644000175000017500000000001410735421714013340 0ustar barakbarak - Fix it zenlisp-2013.11.22/zenlisp.txt0000644000175000017500000006555411064650230014752 0ustar barakbarak zenlisp reference By Nils M Holm, 2007, 2008 Feel free to copy, share, and modify this document. See the file LICENSE for details. 0 Contents 1 . . . . . . . . . . . . . . Forms 1.1 . . . . . . . . . . Abbreviations 1.2 . . . . . . . . . . . . . Comments 1.3 . . . . . . . . . Unreadable Forms 2 . . . . . . . . . . . Expressions 2.1 . . . . . . . . . . . . . Symbols 2.2 . . . . . . . . . . . . Functions 3 . . . . . . . . . . . Some Theory 3.1 . . . . . . . . . Lambda Functions 3.2 . . . . . . . Function Application 4 . . . . . . . Primitive Functions 4.1 . . Composition and Decomposition 4.2 . . . . . . . Binding Constructcs 4.3 . . . . . . . . . . . . Predicates 4.4 . . . . . . . . . . . Control Flow 4.5 . . . . . . . . . . REPL Functions 4.6 . . . . . . . . . . Meta Functions 5 . . . . . . . . Utility Functions 5.1 . . . . . . . . . . List Functions 5.2 . . . . . . . . . . . . Predicates 5.3 . . . . . . . . . . . Control Flow 5.4 . . . . . . . . . . . . . Packages 6 . . . . . . . . . . Math Functions 6.1 . . . . . . . . . . . . . Summary 7 . . . . . . . . . . . Miscellanea 7.1 . . . . . . . . Naming Convention 7.2 . . . . . . . . Evaluation History 7.3 . . . . . . . . . . . Source Path 1 Forms A Symbol is any combination of these characters: a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8 9 0 * + - / < = > An Atom is either a symbol or () (pronounced NIL). A Pair is a concatenation of two forms: (car-part . cdr-part) A pair may contain other pairs: ((a . b) . c) (a . (b . c)) ((a . b) (c . d)) Each Form is either an atom or a pair. 1.1 Abbreviations Some pairs may be abbreviated: (a . ()) = (a) (a . (b)) = (a b) (a . (b . c)) = (a b . c) A List is a pair whose innermost cdr part is (): List = () or (form . list). These are Lists: () (foo) (foo bar baz) ((a . b) foo (nested list)) A list whose innermost cdr part is a symbol is called a Dotted List. These are dotted lists: (a b . c) ((foo bar) . baz) Lists of single-character symbols can be condensed: (a) = '#a (a b c) = '#abc (- 2 5 7) = '#-257 1.2 Comments A comment may be inserted anywhere (even inside of a form) by including a semicolon (;). Comments extend to the end of the current line. Example: (define (f x) ; this is a comment (cons x x)) 1.3 Unreadable Forms A form that is delimited by curly braces is unreadable: {no matter what} => undefined Unreadable forms are used to represent data that have no unambiguous textual representation. 2 Expressions An Expression is a form with a meaning. x => y denotes that x reduces to y; y is the normal form of x. bottom denotes an undefined value. 2.1 Symbols Each symbol reduces to the value bound to it: Symbol => value of symbol Undefined-Symbol => bottom A symbol that is bound to itself is called a Constant, symbols bound to other values are called Variables. 2.2 Functions (F x) denotes the application of f to x. F is called a Function. X is called an Argument. (function) => normal form (function form) => normal form (function form ...) => normal form Function applications are reduced by first reducing arguments to their normal forms and then applying the Function to the resulting normal forms. Pseudo Functions are constructs that are applied in the same way as functions but do not reduce their arguments. 3 Some Theory 3.1 Lambda Functions (Lambda (x) e) is a Lambda Function. X is a variable of that function and E is the Term of that function. Lambda functions are anonymous. If X does not occur in E, the function is constant. X may occur multiple times in E. X is bound in an expression E, if - E is a lambda function AND - X is a variable of E. Examples: X is bound in (lambda (x) x). Y is bound in (lambda (y) (lambda (x) (x y))) Y is not bound in (lambda (x) (x y)) When a variable X is not bound in an expression E, X is free in E; X is a free variable of E. 3.2 Function Application A lambda function is applied to an expression using Beta Reduction. e[x/v] means: replace each X that is free in E with V. Beta reduction: ((lambda (x) e) v) => e[x/v] Examples: a --> b denotes a partial reduction; b is not the normal form of a, because it can be reduced further. ((lambda (x) x) :t) => :t ; identity ((lambda (x) (x x)) :t) --> (:t :t) ; self-application ((lambda (x) (f x)) :t) --> (f :t) ; f is free ((lambda (x) ()) :t) => () ; constant function Functions of multiple variables bind arguments by position: ((lambda (x y z) (list x y z)) 'first 'second 'third) => '(first second third) 4 Primitive Functions The following definitions apply: symbol denotes a variable. 'symbol denotes a constant. eval[x] denotes the normal form of x. x ... denotes zero or more appearances of x. x | y denotes either x or y. Variables become constants when passed as arguments to pseudo functions. A list of pairs is called an Association List (or Alist). The car part of each pair of an alist is called its key and its cdr part is called its value. 4.1 Composition and Decomposition 4.1.1 CAR (car pair) => form Extract the car part of a pair. Examples: (car '(a.b) => 'a (car '(a)) => 'a (car '#abc)) => 'a (car '((ab) c)) => '(ab) (car 'a) => bottom (car ()) => bottom 4.1.2 CDR (cdr pair) => form Extract the cdr part of a pair. Examples: (cdr '(a.b) => 'b (cdr '(a)) => () (cdr '#abc)) => '#bc (cdr '((ab) c)) => '(c) (cdr 'a) => bottom (cdr ()) => bottom 4.1.3 CONS (cons form form) => pair Construct a fresh pair. Examples: (cons 'foo 'bar) => '(foo . bar) (cons 'foo ()) => '(foo) (cons 'foo '(bar)) => '(foo bar) (cons 'a '(b . c) => '(a b . c) (cons () () => (()) (cons '(foo) '(bar)) => '((foo) bar) 4.1.4 EXPLODE (explode symbol) => list Explode a symbol to a list of single-character symbols. If the argument is (), return (). Examples: (explode 'foo) => '(f o o) = '#foo (explode 'x) => '(x) = '#x (explode ()) => () (explode '(a.b)) => bottom 4.1.5 IMPLODE (implode list) => symbol Implode a list of single-character symbols to a symbol. If the argument is (), return (). Examples: (implode '(f o o)) => 'foo (implode '#foo) => 'foo (implode '(x)) => 'x (implode ()) => () (implode '(a (b.c))) => bottom ; non-atom in list (implode '(a bc)) => bottom ; symbol BC too long 4.1.6 QUOTE (quote form) => 'form Indicate normal form. Examples: foo => eval[foo] (quote foo) => 'foo (cons :t :t) => '(:t . :t) (quote (cons :t :t)) => '(cons :t :t) Note: 'foo is just an abbreviation of (quote foo). 4.2 Binding Constructcs 4.2.1 DEFINE (pseudo function) (define symbol form) => 'symbol Bind eval[form] to symbol. Examples: (define foo 'bar) => 'foo ; bind foo to 'bar (define f (lambda (x) x)) => 'f ; bind f to (lambda (x) x) (define (f x) x) => 'f ; bind f to (lambda (x) x) (define (f x . y) y) => 'f ; bind f to (lambda (x . y) y) (define (f . x) x) => 'f ; bind f to (lambda x x) 4.2.2 LAMBDA (pseudo function) (lambda (symbol ...) form) => (closure (symbol ...) form env) Create a closure from a lambda expression. A Closure is a snapshot of a lambda function at a given time. In fact, only closures are valid function in zenlisp while lambda expressions merely create closures. The snapshot is taken by capturing the names and values of all free variables of the term of the lambda function and storing them in an alist. This alist is attached to the closure as the ENV argument. When a closure is applied, the captured bindings be will re-established during the application. Lambda may have zero arguments or more than a single argument: ((lambda () :t)) => :t ((lambda (x y z) z) 'a 'b 'c) => 'c Variadic arguments are implemented using dotted argument lists: ((lambda (x . y) y) 'a) => () ((lambda (x . y) y) 'a 'b) => '(b) ((lambda (x . y) y) 'a 'b 'c) => '(b c) When the argument list is atomic, all arguments are bound to that atom: ((lambda x x)) => () ((lambda x x) 'a) => '(a) ((lambda x x) 'a b c) => '(a b c) Examples: (lambda (x) x) => (closure (x) x ()) (lambda (x) (lambda (y) (cons x y))) => (closure (x) (lambda (y) (cons x y)) ()) ((lambda (x) (lambda (y) (x y))) 'foo) => (closure (y) (x y) ((x . foo))) 4.2.3 LET (pseudo function) (let ((symbol form) ...) term) => eval[term] LET is an alternative syntax for the application of a lambda function: (let ((f1 a1) ... (fN aN)) expr) equals ((lambda (f1 ... fN) expr) a1 ... aN) The first argument of LET is called its environment. It is a list of two-element lists called bindings. The first element of each binding holds the name of the symbol to bind and the second element holds the value to be bound. The term of LET is reduced in the local context created by establishing the bindings of the environment. The context ceases to exist after reducing the term to its normal form. The purpose of LET is to name intermediate results in expressions: (let ((f (lambda (x) (cons x x))) (v 'foo)) (f v)) => '(foo . foo) LET first reduces all values of the environment before it binds any symbols. Therefore, (let ((v :f)) (let ((v :t) (u v)) ; U is bound to the outer value of V u)) => :f 4.2.4 LETREC (pseudo function) (letrec ((symbol form) ...) term) => eval[term] LETREC works like LET, but in addition it fixes recursive bindings using RECURSIVE-BIND (see below). Therefore LETREC can be used to bind recursive functions (even mutually recursive ones) to symbols. 4.2.5 RECURSIVE-BIND (recursive-bind '((symbol . form) ...)) RECURSIVE-BIND fixes recursive references in environments. Its argument is an environment represented by an alist. A recursive reference occurs when a closure closes over the symbol it is bound to: ((f . (closure (x) (f x) ((f . void))))) Because F is closed over before it is bound to the closure, F cannot recurse. Passing above environment to RECURSIVE-BIND yields the following recursive structure: ((f . (closure (x) (f x) ((f . (closure (x) (f x) ((f . (closure (x) (f x) ((f . ... 4.3 Predicates 4.3.1 ATOM (atom form) => :t | :f Reduce to :t, if the given form is atomic and otherwise to :f. Examples: (atom ()) => :t (atom :t) => :t (atom 'foo) => :t (atom '(a.b)) => :f (atom '(a b)) => :f (atom '#foo) => :f 4.3.2 DEFINED (defined 'symbol) => :t | :f Reduce to :t, if the given symbol is bound in any active context (ie by DEFINE or in a surrounding LET or LETREC). Otherwise reduce to :f. Examples: (defined 'undefined) => :f (defined 'defined) => t (defined '(a.b)) => bottom (defined '#foo) => bottom 4.3.3 EQ (eq form1 form2) => :t | :f Reduce to :t, if the given forms are identical and otherwise to :f. Two forms are identical, if they are the same symbol, bound to the same symbol, or if they are both (). Examples: (eq 'foo 'foo) => t (eq foo foo) => t (eq :f :f) => t (eq 'foo 'bar) => :f (eq 'foo '#foo) => :f (eq 'a '(a.b)) => :f (eq '#foo '#foo) => bottom (eq '(a.b) '(a.b)) => bottom 4.4 Control Flow 4.4.1 AND (pseudo function) (and expr ...) => form Reduce the given expressions in sequence until one of them reduces to :f. If one of the expressions reduces to :f, return :f, otherwise return the normal form of the last expression. If no expression is given, return :t. Examples: (and) => t (and 'foo) => 'foo (and :f) => :f (and :f 'foo) => :f (and 'foo :f) => :f (and 'foo 'bar) => 'bar (and 'a 'b 'c :f) => :f 4.4.2 APPLY (apply fun expr ... list) => form Apply the function fun to the given argument list, returning the normal form of the application. When one or multiple expressions are given between the function and the list, cons their normal forms to the list before applying the function. Note: APPLY is called by value, but fun is applied to list using call by name. Examples: (apply cons '(a b)) => '(a . b) (apply cons '('a 'b)) => '('a . 'b) (apply list 'a 'b '(c)) => '(a b c) (apply (lambda () 'foo) ()) => 'foo 4.4.3 BOTTOM (bottom form ...) => bottom Reduce to bottom, thereby stopping the reduction in progress. The given forms print in the resulting error message. Examples: (bottom) => bottom (bottom 'foo) => bottom (bottom 'foo 'bar 'baz) => bottom 4.4.4 COND (pseudo function) (cond (pred expr) (pred expr) ...) => form Reduce expressions conditionally. Each argument of COND is a called a clause. It consists of two expressions: (predicate expression) COND reduces the predicate of the first clause and if it has a true normal form (anything but :f), the entire application of COND reduces to the normal form of the associated expression. COND keeps evaluating clauses until it finds one with a true predicate. At least one predicate must be true. Examples: (cond ('foo 'bar)) => 'bar (cond (:f 'foo) (t 'bar)) => 'bar (cond ((atom ()) (cons 'foo 'bar))) => '(foo . bar) (cond (:f 'oops)) => bottom 4.4.5 OR (pseudo function) (or expr ...) => form Reduce the given expressions in sequence until one of them reduces to :t. If one of the expressions reduces to :t, return :t, otherwise return the normal form of the last expression. If no expression is given, return :f. Examples: (or) => :f (or 'foo) => 'foo (or :f) => :f (or :f 'foo) => 'foo (or 'foo :f) => 'foo (or 'foo 'bar) => 'foo (or :f :f :f 'a) => 'a 4.5 EVAL (eval expr) => form Reduce expr and return its normal form. Examples: (eval '(cons 'a 'b)) => '(a . b) (eval (cons 'a 'b)) => bottom ; = (eval '(a . b)) 4.6 Meta Functions These functions are designed to be applied at the REPL. They are not intended for use in programs. 4.6.1 CLOSURE-FORM (pseudo function) (closure-form args | body | env) => argument | :f Preset the amount of information to be disclosed when printing a closure. (closure-form args) ; this is the default (lambda (foo) bar) => {closure (foo)} (closure-form body) ; also print the body (lambda (foo) bar) => {closure (foo) bar} (closure-form env) ; also print the environment ; given that BAR is bound to BAZ (lambda (foo) bar) => (closure (foo) bar ((bar . baz))) NOTE: (closure-form env) may cause the interpreter to emit *a lot* of information. Printing recursive closures (created using LETREC or RECURSIVE-BIND) may take forever. Literally. Incomplete closures are unreadable because their textual representation is ambiguous. 4.6.2 DUMP-IMAGE (pseudo function) (dump-image file-name) => t Dump an image of the interpreter workspace to the given file. Reduce to :t on success and bottom in case of failure. An image dump may be re-loaded by passing its file name to the interpreter. 4.6.3 GC (pseudo function) (gc) => (free-nodes max-use) Perform a garbage collection and return some information. Free-nodes is the amount of free nodes in the workspace. Max-use is the maximum number of live nodes since the the last application of GC. 4.6.4 LOAD (pseudo function) (load file-name) => t Read the content of the given file as if typed in at the interpreter prompt. A .l suffix will be attached to the given file name, so (load foo) will in fact load the file "foo.l". 4.6.5 QUIT (quit) => Terminate the interpreter. 4.6.6 STATS (pseudo function) (stats expr) => '(normal-form steps nodes gcs) Reduce the given expression to its normal form. Return that normal form plus some additional information. STEPS is the number of reduction steps performed before the normal form was found. NODES is the total number of nodes allocated during the reduction. GCS is the number of garbage collections performed during the reduction. The information delivered by STATS may be used to compare algorithms. 4.6.7 SYMBOLS (symbols) => list Return a list of all symbols in the symbol table. 4.6.8 TRACE (pseudo function) (trace function-name) => :t Tell the interpreter to print applications of the given function before applying it. Use (trace) to turn off tracing. 4.6.9 VERIFY-ARROWS (verify-arrows :t | :f) => :t | :f Turn verification of reduction operators on or off. When verification is off, arrow operators (=>) at the top level act as comments: (verify-arrows :f) (cons 'a 'b) => this is a comment => '(a . b) When verification is on, zenlisp will make sure that the normal form of the expression on the lefthand side of => is equal to the form on its righthand side: (verify-arrows :t) (cons 'a 'b) => '(a . b) => '(a . b) When the verification succeeds, nothing special happens. When the verification fails, an error message is issued: (cons 'a 'b) => 'foo => '(a . b) * 1: REPL: Verification failed; expected: foo 5 Utility Functions 5.1 List Functions 5.1.1 APPEND (append list ...) => list Concatenate lists. Appending () to a list yields the original list. Appending an atom to a list yields a dotted list. Examples: (append '(foo bar) '(baz)) => '(foo bar baz) (append '#abc '#def '#xyz) => '#abcdefxyz (append () '#foo) => '#foo (append '#foo ()) => '#foo (append '(a) '(b . c)) => '(a b . c) (append '#abc 'd) => '(a b c . d) (append () ()) => () (append ()) => () (append) => () 5.1.2 ASSOC / ASSQ (assoc form alist) => pair Retrieve a pair with a given key from an association list. Return :f if no pair has a matching key. Examples: (assoc 'b '((a.1) (b.2))) => '(b . 2) (assoc 'x '((x.1) (x.2))) => '(x . 1) (assoc 'q '((x.1) (x.2))) => :f (assoc '#foo '((#foo . bar))) => '(#foo . bar) ASSQ is similar to ASSOC, but its first argument is limited to symbols: (assq 'b '((a.1) (b.2))) => '(b . 2) (assq '#foo '((#foo . bar))) => :f 5.1.3 CAAR ... CDDDDR (caar list) = (car (car list)) (cadr list) = (car (cdr list)) (cdar list) = (cdr (car list)) (cddr list) = (cdr (cdr list)) (cddddr list) = (cdr (cdr (cdr (cdr list)))) Extract elements of nested lists: Examples: (caar '((key . value)) => 'key (cdar '((key . value)) => 'value (cadr '(first second)) => 'second (caddr '#1234) => '3 (cadddr '#1234) => '4 5.1.4 ID (id form) => form Map a value to itself (identity function). (OK, not really a list function.) Examples: (id 'foo) => 'foo (id (id '#foo)) => '#foo 5.1.5 LIST (list expr ...) => list Form a list from arguments. Unlike members of quoted (constant) lists, the arguments of LIST are reduced before inserting them in the list. Examples: (list) => () (list 'foo) => '(foo) (list 'a 'b 'c) => '#abc '((cons 'a 'b)) => '((cons 'a 'b)) (list (cons 'a 'b)) => '((a . b)) 5.1.6 MEMBER / MEMQ (member expr list) => list (memq symbol list) => list Find a member of a list. Examples: (member 'bar '(foo bar baz)) => '(bar baz) (member '(b.2) '((a.1) (b.2))) => '((b . 2)) (member 'foo '(a b c d e f)) => :f MEMQ is like MEMBER, but its first atgument is limited to symbols: (memq 'bar '(foo bar baz)) => '(bar baz) (memq '(b.2) '((a.1) (b.2))) => :f 5.1.7 REVERSE (reverse list) => list Create a reverse copy of a list: Examples: (reverse '(foo bar)) => '(bar foo) (reverse '(a b c d e f)) => '#fedcba (reverse ()) => () (reverse '(a . b)) => bottom (reverse '(a b c . d)) => bottom 5.2 Predicates 5.2.1 EQUAL (equal form form) => :t | :f Return :t if the two given forms are equal and otherwise :f. Two forms are equal, if they are both the same symbol or if they are pairs containing equal car and cdr parts. Examples: (equal () ()) => t (equal '(a.b) '(a.b)) => t (equal '(f (f x y) z) '(f (f x y) z)) => t (equal '#abcdef '#abcdef) => t (equal 'foo 'bar) => :f (equal '(x (y) z) '(x (q) z)) => :f (equal '#xxx '#xxy) => :f 5.2.2 LISTP (listp form) => :t | :f Return :t if the given form is a (non-dotted) list and otherwise :f. Examples: (listp ()) => t (listp '(a b c)) => t (listp '#abcdef) => t (listp '(a . b)) => :f (listp '(a b . c)) => :f (listp 'foo) => :f 5.2.3 NEQ (neq form form) => :t | :f Return :t if the given forms are not identical and otherwise :f. Examples: (neq 'foo 'bar) => t (neq 'foo '#foo) => t (neq 'a '(a.b)) => t (neq 'foo 'foo) => :f (neq foo foo) => :f (neq () ()) => :f (neq '#foo '#foo) => bottom (neq '(a.b) '(a.b)) => bottom 5.2.4 NOT (not form) => :t | :f Check whether the given form is :f (logical negation). Examples: (not :f) => :t (not ()) => :f (not t) => :f (not 'foo) => :f (not '(a b c)) => :f 5.2.5 NULL (not form) => :t | :f (null form) => :t | () Check whether the given form is (). Examples: (null ()) => t (null :f) => :f (null 'x) => :f (null '(a b c)) => :f 5.3 Control Flow 5.3.1 FOLD (fold fun form list) => form Fold the given list by combining FORM with its first element using the binary function FUN. Combine the result with the second member, etc: (fold f () (a b c d)) = (f (f (f (f () a) b) c) d) If LIST is empty, return FORM. Examples: (fold cons 'a '(b)) => '(a . b) (fold cons 'a '(b c d)) => '(((a . b) . c) . d) (fold cons 'a ()) => 'a 5.3.2 FOLD-R (fold-r fun form list) => form Fold the given list by combining its head with its reduced tail using the binary function FUN. While FOLD combines its arguments left-associatively, FOLD-R combines them right-associatively: (fold-r f () (a b c d)) = (f a (f b (f c (f d ())))) If LIST is empty, return FORM. Examples: (fold-r cons a '(b)) => '(a . b) (fold-r cons 'a '(b c d)) => '(a b c . d) (fold-r cons 'a ()) => 'a 5.3.3 MAP (map fun list list ...) => list Map the given function over the given list(s). The function must take the same number of arguments as there are lists. The N'th member of the resulting list is the result of applying FUN to the N'th members of all input list. Examples: (map car '((a) (b) (c))) => '#abc (map cdr '((a) (b) (c))) => '(() () ()) (map cons '(a b c) '(d e f)) => '((a . d) (b . e) (c . f)) (map list '(a b) '(c d) '(e f)) => '(#ace #bdf)) 5.4 Packages 5.4.1 REQUIRE (require 'package-name) => :t | :f Load a package (using LOAD) if it is not already present. REQUIRE checks the presence of a package by testing whether the given package name is defined. Packages are required to define that name *before* requiring other packages. Examples: (require 'nmath) => :t ; load natural math functions (require 'nmath) => :f ; already loaded 6 Math Functions zenlisp implements math numbers as lists of digits: 123 is written as '(1 2 3) or '#123. Rational numbers are numbers containing a slash: -5/4 is written as '(- 5 / 4) or '#-5/4. Math functions are not part of the default image. To load them use (load nmath) ; load natural math functions or (load imath) ; load integer math functions (includes nmath) or (load rmath) ; load rational math functions (includes imath) To create an image with all math functions, type (load rmath) (dump-image math-image) and run zenlisp using zl math-image 6.1 Summary ... indicates repetition. [x] indicates that x is optional. x|y indicates x or y. x = number; n = natural; i = integer; r = rational. Function Returns... (* [x ...]) => x product *epsilon* => n log10 of precision of SQRT (+ [x ...]) => x sum (- x1 x2 [...]) => x difference (- x) => x negative number (/ x1 x2) => x ratio (< x1 x2 [...]) => :t|:f :t for strict ascending order (<= x1 x2 [...]) => :t|:f :t for strict non-descending order (= x1 x2 [...]) => :t|:f :t for equivalence (> x1 x2 [...]) => :t|:f :t for strict descending order (>= x1 x2 [...]) => :t|:f :t for strict non-ascending order (abs x) => x absolute value (denominator r) => i denominator (divide i1 i2) => (i3 i4) quotient i3 and remainder i4 (even i) => :t|:f :t, if i is even (expt x i) => x x to the power of i (gcd [i1 ...]) => n greatest common divisor (integer x) => i an integer with the value x (integer-p x) => :t|:f :t, if x is integer (lcm [i1 ...]) => n least common multiple (length list) => n length of a list (limit op x1 ...) => x find the limit of x1... under op (max x1 [x2 ...]) => x maximum value (min x1 [x2 ...]) => x minimum value (modulo i1 i2) => i3 modulus (natural x) => n a natural with the value x (natural-p x) => :t|:f :t, if x is natural (negate i|r) => i|r negative value (negative x) => :t|:f :t, if x is negative (number-p expr) => :t|:f :t, if expr represents a number (numerator r) => i numerator (odd i) => :t|:f :t, if i is not even (one x) => :t|:f :t, if x equals one (quotient i1 i2) => i quotient (rational x) => r a rational with the value x (rational-p x) => :t|:f :t, if x is rational (remainder i1 i2) => i division remainder (sqrt n) => x square root, see also *espilon* (zero x) => :t|:f :t, if x equals zero [*] The result of SQRT depends on the library in use. The natural and integer versions return the greatest natural number whose square is not larger than the argument. The rational version returns a number that differs from the actual square root of the argument by no more than (/ '#1 (expt '#10 *epsilon*)), where *epsilon* is a global variable. 7 Miscellanea 7.1 Naming convention Symbols starting and ending with an asterisk are reserved for the code implementing zenlisp. They must be avoided in user-level code. 7.2 Evaluation History The normal form most recently produced by the interpreter is bound to the symbol **: (car '(first second)) => 'first (cons ** **) => '(first . first) 7.3 Source Path When loading code using LOAD or REQUIRE, the following abbreviations may be used: (load ~nmath) (require '~nmath) both load the file "nmath.l" from the directory specified in the environment variable ZENSRC. When a file "foo" that is being loaded loads another file "bar", the file "bar" is assumed to reside in the same directory as "foo". When "foo" is loaded using (load /baz/foo) the function application (load bar) in the file "foo" actually loads /baz/bar. zenlisp-2013.11.22/zl.10000644000175000017500000000441611064427130013223 0ustar barakbarak.\" ZENLISP(1) Manual Page .\" By Nils M Holm, 2007, 2008 .\" See the file LICENSE for conditions of use. .ll 70 .lt 70 .ds N "pi .de HD \" Header 'sp 1v .tl 'zl(1)''zl(1)' 'sp 2v .. .de FO \" Footer 'sp 3v .tl 'zenlisp''Page %' 'bp .. .de B \fB\\$1\fP .. .de BR \fB\\$1\fP\\$2 .. .de RB \\$1\fB\\$2\\fP .. .de I \fI\\$1\fP .. .de IT .br .sp .ti +\\$1 .. .de SH \" subheader macro .ne 5 .sp .in 0i .nf \fB\\$1\fP .fi .in 1i .. .de ST \" start a table .in 1i .nf .. .de ET \" end a table .fi .in 0 .. .wh 0 HD \" traps for header .wh -5 FO \" and footer .nh \" disable hyphenation .sp .SH NAME .B "zl - zenlisp interpreter .SH USAGE .B "zl [-L] [-bgi] [-n nodes] [image] .SH "DESCRIPTION .B Zenlisp is an interpreter for a purely symbolic and applicative dialect of LISP. It may be considered an implementation of pure LISP plus global definitions. .sp The .I zl command starts the interpreter. .SH "OPTIONS .B -b .in +4 Batch mode. In batch mode, no greeting message is printed, and the interpreter exists in case of an error rather than returning to the read-eval-print loop. .in -4 .sp .B -g .in +4 Verbose GC. Report number of free nodes after each GC. .in -4 .sp .B -i .in +4 Init mode. Init mode is used to build the initial image file. No image is loaded. .B "Do not use this option. .in -4 .sp .B "-n nodes .in +4 Specify the size of the node pool. Larger pools (up to some limit) increase performance. The memory footprint of the zenlisp workspace is calculated as follows: .sp nodes * (sizeof(int) * 2 + 1) .in -4 .sp .B "-L .in +4 Display the terms of use (license) and exit. .in -4 .sp If an .B image file name is passed to the .I zl command, the specified image is loaded instead of the default image. .SH "FURTHER INFORMATION Further information about zenlisp is not available in manual page format. The reference manual in ASCII format can be found in the file .sp .I PREFIX/share/doc/zenlisp/zenlisp.txt .sp (The actual location of .I PREFIX may vary on your system. By default, it is \fI/usr/local\fP.) .SH "FILES .B PREFIX/share/zenlisp .in +4 The extension libraries and example programs reside here. .in -4 .SH "ENVIRONMENT .B ZENSRC .in +4 The location of the libraries and example programs. .B "(load ~file) loads .I file from \fI$ZENSRC/file\fP. .in -4 .SH AUTHOR Nils M Holm zenlisp-2013.11.22/zl.c0000644000175000017500000016260512243656650013325 0ustar barakbarak/* * zenlisp -- an interpreter for symbolic LISP * By Nils M Holm , 2007,2008,2013 * Feel free to copy, share, and modify this program. * See the file LICENSE for details. */ #include #ifdef __TURBOC__ #include #include #else #include #ifndef __MINGW32__ #ifndef __CYGWIN__ #define setmode(fd, mode) #endif #endif #endif #include #include #include #include #define VERSION 2 #define RELEASE "2013-11-22" /* * Number of nodes and vector cells. * Memory = Nodes * (2 * sizeof(int) + 1) */ #define DEFAULT_NODES 131072 #define MINIMUM_NODES 12280 #ifndef DEFAULT_IMAGE #define DEFAULT_IMAGE "/u/share/zenlisp/zenlisp" #endif struct counter { int n, n1k, n1m, n1g; }; struct Error_context { char *msg; char *arg; int expr; char *file; int line; int fun; int frame; }; #define SYMBOL_LEN 256 #define MAX_PATH_LEN 256 /* Tags */ #define ATOM_FLAG 0x01 /* Atom: (CAR = char, CDR = next) */ #define MARK_FLAG 0x02 /* garbage collector: mark */ #define SWAP_FLAG 0x04 /* garbage collector: swap CAR/CDR */ #define NIL -1 #define EOT -2 #define DOT -3 #define R_PAREN -4 #define NO_EXPR -5 enum Evaluator_states { MATOM = '0', /* Processing Atom */ MLIST, /* Processing List */ MBETA, /* Beta-reducing */ MBIND, /* Processing bindings of LET */ MBINR, /* Processing bindings of LETREC */ MLETR, /* Finish LET or LETREC */ MCOND, /* Processing predicates of COND */ MCONJ, /* Processing arguments of AND */ MDISJ /* Processing arguments of OR */ }; int Pool_size; int *Car, /* Car*Cdr*Tag = Node Pool */ *Cdr; char *Tag; int Freelist; int Tmp_car, Tmp_cdr; /* GC-safe */ int Tmp, Tmp2; char *Infile; FILE *Input; int Rejected; int Line; FILE *Output; char Source_dir[MAX_PATH_LEN]; char Expanded_path[MAX_PATH_LEN]; char Current_path[MAX_PATH_LEN]; int Error_flag; struct Error_context Error; int Fatal_flag; int Symbols; int Safe_symbols; int Stack, Stack_bottom; int Mode_stack; int Arg_stack; int Bind_stack; int Env_stack; int Frame; int Function_name; int Traced_fn; int *Root[] = { &Symbols, &Stack, &Mode_stack, &Arg_stack, &Bind_stack, &Env_stack, &Tmp_car, &Tmp_cdr, &Tmp, &Tmp2, &Safe_symbols, NULL }; int Lexical_env; int Bound_vars; int Paren_level; int Load_level; int Eval_level; int Quotedprint; int Max_atoms_used; int Max_trace; int Stat_flag; int Closure_form; int Verify_arrows; int Verbose_GC; struct counter Reductions, Allocations, Collections; /* Builtin symbol pointers for fast lookup */ int S_bottom, S_closure, S_false, S_lambda, S_primitive, S_quote, S_special, S_special_cbv, S_true, S_void, S_last; /* Primitive function opcodes */ enum { P_ATOM, P_BOTTOM, P_CAR, P_CDR, P_CONS, P_DEFINED, P_EQ, P_EXPLODE, P_GC, P_IMPLODE, P_QUIT, P_RECURSIVE_BIND, P_SYMBOLS, P_VERIFY_ARROWS, N_PRIMITIVES }; int (*Primitives[N_PRIMITIVES])(int); /* Special form opcodes */ enum { SF_AND, SF_APPLY, SF_CLOSURE_FORM, SF_COND, SF_DEFINE, SF_DUMP_IMAGE, SF_EVAL, SF_LAMBDA, SF_LET, SF_LETREC, SF_LOAD, SF_OR, SF_QUOTE, SF_STATS, SF_TRACE, N_SPECIALS }; int (*Specials[N_SPECIALS])(int, int *, int *, int *); #ifdef LINT #define USE(arg) (arg = NIL) #else #define USE(arg) #endif int _rdch(void); int add_primitive(char *name, int opcode); int add_special(char *name, int opcode, int cbv); int add_symbol(char *s, int v); int alloc3(int pcar, int pcdr, int ptag); int aunsave(int k); int bad_argument_list(int n); void bind_args(int n, int name); int bunsave(int k); void catch_int(int sig); void clear_stats(void); void collect_free_vars(int n); int cond_get_pred(void); int cond_eval_clause(int n); int cond_setup(int n); int copy_bindings(void); void count(struct counter *c, int k); char *counter_to_string(struct counter *c, char *buf); int define_function(int n); int dump_image(char *p); int equals(int n, int m); void eliminate_tail_calls(void); int error(char *m, int n); int eval(int n); char *expand_path(char *s, char *buf); int explode_string(char *sym); void fatal(char *m); int find_symbol(char *s); void fix_all_closures(int b); void fix_cached_closures(void); void fix_closures_of(int n, int bindings); int flat_copy(int n, int *lastp); int gc(void); int get_opt_val(int argc, char **argv, int *pi, int *pj, int *pk); void get_options(int argc, char **argv); void get_source_dir(char *path, char *pfx); char *symbol_to_string(int n, char *b, int k); void help(void); void init(void); void init1(void); void init2(void); int is_alist(int n); int is_bound(int n); int is_list_of_symbols(int m); void let_bind(int env); int let_eval_arg(void); int let_finish(int rec); int let_next_binding(int n); int let_setup(int n); int load(char *p); int make_closure(int n); void mark(int n); int make_lexical_env(int term, int locals); char *make_zen_path(char *s); int munsave(void); void nl(void); void print(int n); int reverse_in_situ(int n); void pr(char *s); int primitive(int *np); void print_call_trace(int n); int print_closure(int n, int dot); int print_condensed_list(int n, int dot); int print_primitive(int n, int dot); int print_quoted_form(int n, int dot); void print_trace(int n); void print_license(void); void pr_num(int n); int quote(int n); int read_condensed(void); void read_eval_loop(void); int read_list(void); int read_symbol(int c); void repl(void); void reset_counter(struct counter *c); void reset_state(void); void restore_bindings(int values); int setup_and_or(int n); int special(int *np, int *pcf, int *pmode, int *pcbn); int string_to_symbol(char *s); char *symbol_to_string(int n, char *b, int k); void unbind_args(void); int unreadable(void); int unsave(int k); void usage(void); void verify(void); int wrong_arg_count(int n); int z_and(int n, int *pcf, int *pmode, int *pcbn); int z_apply(int n, int *pcf, int *pmode, int *pcbn); int z_atom(int n); int z_bottom(int n); int z_car(int n); int z_cdr(int n); int z_closure_form(int n, int *pcf, int *pmode, int *pcbn); int z_cond(int n, int *pcf, int *pmode, int *pcbn); int z_cons(int n); int z_define(int n, int *pcf, int *pmode, int *pcbn); int z_defined(int n); int z_dump_image(int n, int *pcf, int *pmode, int *pcbn); int z_eq(int n); int z_eval(int n, int *pcf, int *pmode, int *pcbn); int z_explode(int n); int z_gc(int n); int z_implode(int n); int z_lambda(int n, int *pcf, int *pmode, int *pcbn); int z_let(int n, int *pcf, int *pmode, int *pcbn); int z_letrec(int n, int *pcf, int *pmode, int *pcbn); int z_load(int n, int *pcf, int *pmode, int *pcbn); int z_or(int n, int *pcf, int *pmode, int *pcbn); int z_quit(int n); int z_quote(int n, int *pcf, int *pmode, int *pcbn); int z_recursive_bind(int n); int z_stats(int n, int *pcf, int *pmode, int *pcbn); int z_symbols(int n); int z_trace(int n, int *pcf, int *pmode, int *pcbn); int z_verify_arrows(int n); int zen_eval(int n); void zen_fini(void); int zen_init(int nodes, int trackGc); char **zen_license(void); int zen_load_image(char *p); void zen_print(int n); void zen_print_error(void); int zen_read(void); void zen_stop(void); int zread(void); #define caar(x) (Car[Car[x]]) #define cadr(x) (Car[Cdr[x]]) #define cdar(x) (Cdr[Car[x]]) #define cddr(x) (Cdr[Cdr[x]]) #define caaar(x) (Car[Car[Car[x]]]) #define caadr(x) (Car[Car[Cdr[x]]]) #define cadar(x) (Car[Cdr[Car[x]]]) #define caddr(x) (Car[Cdr[Cdr[x]]]) #define cdaar(x) (Cdr[Car[Car[x]]]) #define cddar(x) (Cdr[Cdr[Car[x]]]) #define cdddr(x) (Cdr[Cdr[Cdr[x]]]) #define caddar(x) (Car[Cdr[Cdr[Car[x]]]]) #define cadddr(x) (Car[Cdr[Cdr[Cdr[x]]]]) void nl(void) { putc('\n', Output); if (Output == stdout) fflush(Output); } void pr(char *s) { fputs(s, Output); } void pr_num(int n) { fprintf(Output, "%d", n); } void print_call_trace(int frame) { int s, n; s = frame; n = Max_trace; while (s != NIL) { if (n == 0 || Cdr[s] == NIL || cadr(s) == NIL) break; if (n == Max_trace) pr("* Trace:"); n = n-1; pr(" "); Quotedprint = 1; print(cadr(s)); s = Car[s]; } if (n != Max_trace) nl(); } /* Register error */ int error(char *m, int n) { if (Error_flag) return NIL; Error.msg = m; Error.expr = n; Error.file = Infile; Error.line = Line; Error.fun = Function_name; Error.frame = Frame; Error_flag = 1; return NIL; } void zen_print_error(void) { pr("* "); if (Error.file) { pr(Error.file); pr(": "); } pr_num(Error.line); pr(": "); if (Error.fun != NIL) { Quotedprint = 1; print(Error.fun); } else { pr("REPL"); } pr(": "); pr(Error.msg); if (Error.expr != NO_EXPR) { if (Error.msg[0]) pr(": "); Quotedprint = 1; print(Error.expr); } nl(); if (Error.arg) { pr("* "); pr(Error.arg); nl(); Error.arg = NULL; } if (!Fatal_flag && Error.frame != NIL) print_call_trace(Error.frame); Error_flag = 0; } void fatal(char *m) { Error_flag = 0; Fatal_flag = 1; error(m, NO_EXPR); zen_print_error(); pr("* Fatal error, aborting"); nl(); exit(1); } void reset_counter(struct counter *c) { c->n = 0; c->n1k = 0; c->n1m = 0; c->n1g = 0; } /* Assert 0<=k<=1000 */ void count(struct counter *c, int k) { char *msg = "statistics counter overflow"; c->n = c->n+k; if (c->n >= 1000) { c->n = c->n - 1000; c->n1k = c->n1k + 1; if (c->n1k >= 1000) { c->n1k = 0; c->n1m = c->n1m+1; if (c->n1m >= 1000) { c->n1m = 0; c->n1g = c->n1g+1; if (c->n1g >= 1000) { error(msg, NO_EXPR); } } } } } char *counter_to_string(struct counter *c, char *buf) { int i; i = 0; if (c->n1g) { sprintf(&buf[i], "%d,", c->n1g); i = strlen(buf); } if (c->n1m || c->n1g) { if (c->n1g) sprintf(&buf[i], "%03d,", c->n1m); else sprintf(&buf[i], "%d,", c->n1m); i = strlen(buf); } if (c->n1k || c->n1m || c->n1g) { if (c->n1g || c->n1m) sprintf(&buf[i], "%03d,", c->n1k); else sprintf(&buf[i], "%d,", c->n1k); i = strlen(buf); } if (c->n1g || c->n1m || c->n1k) sprintf(&buf[i], "%03d", c->n); else sprintf(&buf[i], "%d", c->n); return buf; } /* * Mark nodes which can be accessed through N. * This routine uses the Deutsch/Schorr/Waite algorithm * (aka pointer reversal algorithm) which marks the * nodes of a pool in constant space. * It uses the MARK_FLAG (M) and SWAP_FLAG (S) to keep track * of the state of the current node. * Each visited node goes through these states: * State 1: M=0 S=0; unvisited, process CAR (skipped for atoms) * State 2: M=1 S=1; CAR visited, process CDR * State 3: M=1 S=0; completely visited, return to parent */ void mark(int n) { int p, parent; parent = NIL; while (1) { if (n == NIL || Tag[n] & MARK_FLAG) { if (parent == NIL) break; if (Tag[parent] & SWAP_FLAG) { /* State 2: */ /* Swap CAR and CDR pointers and */ /* proceed with CDR. Set State=3. */ p = Cdr[parent]; Cdr[parent] = Car[parent]; Car[parent] = n; Tag[parent] &= ~SWAP_FLAG; /* S=0 */ Tag[parent] |= MARK_FLAG; /* M=1 */ n = p; } else { /* State 3: */ /* Return to the parent and restore */ /* parent of parent */ p = parent; parent = Cdr[p]; Cdr[p] = n; n = p; } } else { /* State 1: */ if (Tag[n] & ATOM_FLAG) { /* If this node is an atom, go directly */ /* to state 3. */ p = Cdr[n]; Cdr[n] = parent; /*Tag[n] &= ~SWAP_FLAG;*/ /* S=0 */ parent = n; n = p; Tag[parent] |= MARK_FLAG; /* M=1 */ } else { /* Go to state 2: */ p = Car[n]; Car[n] = parent; Tag[n] |= MARK_FLAG; /* M=1 */ parent = n; n = p; Tag[parent] |= SWAP_FLAG; /* S=1 */ } } } } /* Mark and Sweep Garbage Collection. */ int gc(void) { int i, k; k = 0; for (i=0; Root[i]; i++) mark(Root[i][0]); if (Error_flag) { mark(Error.expr); mark(Error.fun); mark(Error.frame); } Freelist = NIL; for (i=0; i= SYMBOL_LEN-2) { error("symbol too long", NO_EXPR); i = i-1; } s[i] = c; i = i+1; c = rdch(); } s[i] = 0; Rejected = c; return add_symbol(s, S_void); } int equals(int n, int m) { if (n == m) return 1; if (n == NIL || m == NIL) return 0; if (Tag[n] & ATOM_FLAG || Tag[m] & ATOM_FLAG) return 0; return equals(Car[n], Car[m]) && equals(Cdr[n], Cdr[m]); } void verify(void) { int expected; expected = zread(); if (!atomic(expected) && Car[expected] == S_quote) expected = cadr(expected); if (!equals(expected, Cdr[S_last])) error("Verification failed; expected", expected); } int unreadable(void) { #define L 256 int c, i; static char b[L]; i = 0; b[0] = '{'; c = '{'; while (c != '}' && c != EOT && i < L-2) { b[i++] = c; c = rdch(); } b[i] = '}'; b[i+1] = 0; Error.arg = b; return error("unreadable object", NO_EXPR); } int zread(void) { int c; c = rdch(); while (1) { while (c == ' ' || c == '\t' || c == '\n' || c == '\r') { if (Error_flag) return NIL; c = rdch(); } if (c == '=' && Paren_level == 0) { c = rdch(); if (c != '>') { Rejected = c; c = '='; break; } if (Verify_arrows) verify(); } else if (c != ';') { break; } while (c != '\n') c = rdch(); } if (c == EOT) return EOT; if (c == '(') { return read_list(); } else if (c == '\'') { return quote(zread()); } else if (c == '#') { return read_condensed(); } else if (c == ')') { if (!Paren_level) return error("unexpected ')'", NO_EXPR); return R_PAREN; } else if (c == '.') { if (!Paren_level) return error("unexpected '.'", NO_EXPR); return DOT; } else if (c == '{') { return unreadable(); } else { return read_symbol(c); } } int wrong_arg_count(int n) { return error("wrong argument count", n); } int bad_argument_list(int n) { return error("bad argument list", n); } int z_cons(int n) { int m, m2; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrong_arg_count(n); m2 = cadr(m); m = alloc(Car[m], m2); return m; } int z_car(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); m = Car[m]; if ( atomic(m) || Car[m] == S_primitive || Car[m] == S_special || Car[m] == S_special_cbv ) return error("car: cannot split atoms", m); return Car[m]; } int z_cdr(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); m = Car[m]; if ( atomic(m) || Car[m] == S_primitive || Car[m] == S_special || Car[m] == S_special_cbv ) return error("cdr: cannot split atoms", m); return Cdr[m]; } int z_eq(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrong_arg_count(n); return Car[m] == cadr(m)? S_true: S_false; } int z_atom(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); if atomic(Car[m]) return S_true; m = caar(m); return (m == S_primitive || m == S_special || m == S_special_cbv || m == S_void)? S_true: S_false; } int z_explode(int n) { int m, y, a; char s[2]; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); m = Car[m]; if (m == NIL) return NIL; if (!symbolic(m)) return error("explode: got non-symbol", m); y = alloc(NIL, NIL); save(y); a = y; m = Car[m]; s[1] = 0; while (m != NIL) { s[0] = Car[m]; Car[a] = add_symbol(s, S_void); m = Cdr[m]; if (m != NIL) { Cdr[a] = alloc(NIL, NIL); a = Cdr[a]; } } unsave(1); return y; } int z_implode(int n) { int m, i; char s[SYMBOL_LEN]; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); m = Car[m]; if (m == NIL) return NIL; i = 0; while (m != NIL) { if (!symbolic(Car[m])) return error("implode: non-symbol in argument", Car[m]); if (cdaar(m) != NIL) return error( "implode: input symbol has multiple characters", Car[m]); if (i >= SYMBOL_LEN-1) return error("implode: output symbol too long", m); s[i] = caaar(m); i += 1; m = Cdr[m]; } s[i] = 0; return add_symbol(s, S_void); } void fix_cached_closures(void) { int a, ee, e; if (Error_flag || Env_stack == NIL || Env_stack == S_true) return; a = Car[Bind_stack]; while (a != NIL) { ee = Env_stack; while (ee != NIL && ee != S_true) { e = Car[ee]; while (e != NIL) { if (Car[a] == caar(e)) { cdar(e) = cdar(a); break; } e = Cdr[e]; } ee = Cdr[ee]; } a = Cdr[a]; } } int is_alist(int n) { if (symbolic(n)) return 0; while (n != NIL) { if (symbolic(Car[n]) || !symbolic(caar(n))) return 0; n = Cdr[n]; } return 1; } void fix_closures_of(int n, int bindings) { int ee, e; int bb, b; if (atomic(n)) return; if (Car[n] == S_closure) { fix_closures_of(caddr(n), bindings); ee = cdddr(n); if (ee == NIL) return; ee = Car[ee]; while (ee != NIL) { e = Car[ee]; bb = bindings; while (bb != NIL) { b = Car[bb]; if (Car[b] == Car[e]) Cdr[e] = Cdr[b]; bb = Cdr[bb]; } ee = Cdr[ee]; } return; } fix_closures_of(Car[n], bindings); fix_closures_of(Cdr[n], bindings); } void fix_all_closures(int b) { int p; p = b; while (p != NIL) { fix_closures_of(cdar(p), b); p = Cdr[p]; } } int z_recursive_bind(int n) { int m, env; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); env = Car[m]; if (!is_alist(env)) return error("recursive-bind: bad environment", env); fix_all_closures(env); return env; } int z_bottom(int n) { n = alloc(S_bottom, Cdr[n]); return error("", n); } int z_defined(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); if (!symbolic(Car[m])) return error("defined: got non-symbol", Car[m]); return cdar(m) == S_void? S_false: S_true; } int z_gc(int n) { int m; char s[20]; m = Cdr[n]; if (m != NIL) return wrong_arg_count(n); n = alloc(NIL, NIL); save(n); sprintf(s, "%d", gc()); Car[n] = explode_string(s); Cdr[n] = alloc(NIL, NIL); sprintf(s, "%d", Max_atoms_used); Max_atoms_used = 0; cadr(n) = explode_string(s); unsave(1); return n; } int z_quit(int n) { int m; m = Cdr[n]; if (m != NIL) return wrong_arg_count(n); zen_fini(); exit(0); } int z_symbols(int n) { int m; m = Cdr[n]; if (m != NIL) return wrong_arg_count(n); return Symbols; } int z_verify_arrows(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); m = Car[m]; if (m != S_true && m != S_false) return error("verify-arrows: got non truth-value", m); Verify_arrows = m == S_true; return m; } /* If (CAR NP[0]) is a builtin procedure, run it. */ int primitive(int *np) { int n, y; int (*op)(int); n = np[0]; y = Car[n]; if (Error_flag) return 0; if (Car[y] == S_primitive) { op = Primitives[cadr(y)]; } else { return 0; } n = (*op)(n); np[0] = n; return 1; } int setup_and_or(int n) { int m; m = Cdr[n]; if (m == NIL) return wrong_arg_count(n); bsave(m); return Car[m]; } int z_and(int n, int *pcf, int *pmode, int *pcbn) { USE(pcbn); if (Cdr[n] == NIL) { return S_true; } else if (cddr(n) == NIL) { *pcf = 1; return cadr(n); } else { *pcf = 2; *pmode = MCONJ; return setup_and_or(n); } } int flat_copy(int n, int *lastp) { int a, m, last; if (n == NIL) { lastp[0] = NIL; return NIL; } m = alloc(NIL, NIL); save(m); a = m; last = m; while (n != NIL) { Car[a] = Car[n]; last = a; n = Cdr[n]; if (n != NIL) { Cdr[a] = alloc(NIL, NIL); a = Cdr[a]; } } unsave(1); lastp[0] = last; return m; } int z_apply(int n, int *pcf, int *pmode, int *pcbn) { int m, p, q, last; char *err1 = "apply: got non-function", *err2 = "apply: improper argument list"; *pcf = 1; USE(pmode); *pcbn = 1; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL) return wrong_arg_count(n); if (atomic(Car[m])) return error(err1, Car[m]); p = caar(m); if ( p != S_primitive && p != S_special && p != S_special_cbv && p != S_closure ) return error(err1, Car[m]); p = Cdr[m]; USE(last); while (p != NIL) { if (symbolic(p)) return error(err2, cadr(m)); last = p; p = Cdr[p]; } p = Car[last]; while (p != NIL) { if (symbolic(p)) return error(err2, Car[last]); p = Cdr[p]; } if (cddr(m) == NIL) { p = cadr(m); } else { p = flat_copy(Cdr[m], &q); q = p; while (cddr(q) != NIL) q = Cdr[q]; Cdr[q] = Car[last]; } return alloc(Car[m], p); } int cond_get_pred(void) { int e; e = caar(Bind_stack); if (atomic(e) || atomic(Cdr[e]) || cddr(e) != NIL) return error("cond: bad clause", e); return Car[e]; } int cond_setup(int n) { int m; m = Cdr[n]; if (m == NIL) return wrong_arg_count(n); bsave(m); return cond_get_pred(); } /* * Evaluate next clause of COND. * N is the value of the current predicate. * If N=T, return the expression of the predicate. * If N=:F, return the predicate of the next clause. * When returning the expression of a predicate (N=T), * set the context on the Bind_stack to NIL to signal that * a true clause was found. */ int cond_eval_clause(int n) { int e; e = Car[Bind_stack]; if (n == S_false) { Car[Bind_stack] = Cdr[e]; if (Car[Bind_stack] == NIL) return error("cond: no default", NO_EXPR); return cond_get_pred(); } else { e = cadar(e); Car[Bind_stack] = NIL; return e; } } int z_cond(int n, int *pcf, int *pmode, int *pcbn) { *pcf = 2; *pmode = MCOND; USE(pcbn); return cond_setup(n); } int is_list_of_symbols(int m) { while (m != NIL) { if (!symbolic(Car[m])) return 0; if (symbolic(Cdr[m])) break; m = Cdr[m]; } return 1; } int define_function(int n) { int m, y; m = Cdr[n]; if (Car[m] == NIL) return error("define: missing function name", Car[m]); if (!is_list_of_symbols(Car[m])) return bad_argument_list(Car[m]); y = caar(m); save(cadr(m)); Tmp2 = alloc(S_lambda, NIL); Cdr[Tmp2] = alloc(cdar(m), NIL); cddr(Tmp2) = alloc(cadr(m), NIL); cdddr(Tmp2) = alloc(NIL, NIL); Cdr[y] = eval(Tmp2); Tmp2 = NIL; unsave(1); return y; } int z_define(int n, int *pcf, int *pmode, int *pcbn) { int m, v, y; USE(pcf); USE(pmode); USE(pcbn); if (Eval_level > 1) { error("define: limited to top level", NO_EXPR); return NIL; } m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrong_arg_count(n); y = Car[m]; if (!symbolic(y)) return define_function(n); v = cadr(m); save(v); /* If we are binding to a lambda expression, */ /* add a null environment */ if (!atomic(v) && Car[v] == S_lambda) { if ( Cdr[v] != NIL && cddr(v) != NIL && cdddr(v) == NIL ) { cdddr(v) = alloc(NIL, NIL); } } Cdr[y] = eval(cadr(m)); unsave(1); return y; } int z_eval(int n, int *pcf, int *pmode, int *pcbn) { int m; *pcf = 1; USE(pmode); *pcbn = 0; m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); return (Car[m]); } int is_bound(int n) { int b; b = Bound_vars; while (b != NIL) { if (symbolic(b)) { if (n == b) return 1; break; } if (n == Car[b]) return 1; b = Cdr[b]; } b = Car[Lexical_env]; while (b != NIL) { if (caar(b) == n) return 1; b = Cdr[b]; } return 0; } void collect_free_vars(int n) { if (n == NIL || (Tag[n] & ATOM_FLAG)) return; if (symbolic(n)) { if (is_bound(n)) return; Car[Lexical_env] = alloc(NIL, Car[Lexical_env]); caar(Lexical_env) = alloc(n, Car[n] == Cdr[n]? n: Cdr[n]); return; } /* * Avoid inclusion of quoted forms. * We cannot just check for Car[n] == S_quote, * because this would also catch (list quote foo). * By checking caar(n), we make sure that QUOTE * actually is in a car position. * NOTE: this also prevents (quote . (internal quote)) * from being included, but who wants to re-define * QUOTE anyway? */ if (atomic(Car[n]) || caar(n) != S_quote) collect_free_vars(Car[n]); collect_free_vars(Cdr[n]); } int make_lexical_env(int term, int locals) { Lexical_env = alloc(NIL, NIL); save(Lexical_env); Bound_vars = locals; collect_free_vars(term); unsave(1); return Car[Lexical_env]; } int make_closure(int n) { int cl, env, args, term; if (Error_flag) return NIL; args = cadr(n); term = caddr(n); if (cdddr(n) == NIL) { env = make_lexical_env(term, args); if (env != NIL) { if (Env_stack != NIL) Env_stack = alloc(env, Env_stack); cl = alloc(env, NIL); } else { cl = NIL; } } else { cl = alloc(cadddr(n), NIL); } cl = alloc(term, cl); cl = alloc(args, cl); cl = alloc(S_closure, cl); return cl; } int z_lambda(int n, int *pcf, int *pmode, int *pcbn) { int m; m = Cdr[n]; if ( m == NIL || Cdr[m] == NIL || (cddr(m) != NIL && cdddr(m) != NIL) ) return wrong_arg_count(n); if (cddr(m) != NIL && !is_alist(caddr(m))) return error("lambda: bad environment", caddr(m)); if (!symbolic(Car[m]) && !is_list_of_symbols(Car[m])) return bad_argument_list(Car[m]); return Car[n] == S_closure? n: make_closure(n); } void unbind_args(void) { int v; Frame = unsave(1); Function_name = unsave(1); v = bunsave(1); while (v != NIL) { cdar(v) = unsave(1); v = Cdr[v]; } } /* * Set up a context for reduction of * N=(LET ((MA1 eval[MX2]) ...) MN) * and N=(LETREC ((MA1 eval[MX2]) ...) MN). * Save * - the complete LET/LETREC expression on the Bind_stack * - the environment on the Bind_stack * - a list of new bindings on the Bind_stack (initially empty) * - a list of saved names on the Stack (initially empty) */ int let_setup(int n) { int m; m = Cdr[n]; if (m == NIL || Cdr[m] == NIL || cddr(m) != NIL) return wrong_arg_count(n); m = Car[m]; if (symbolic(m)) return error("let/letrec: bad environment", m); bsave(n); /* save entire LET/LETREC */ bsave(m); /* save environment */ bsave(NIL); /* list of bindings */ bsave(NIL); /* save empty name list */ save(Env_stack); /* get outer bindings out of the way */ Env_stack = NIL; return m; } /* * Process one binding of LET/LETREC. * Return: * non-NIL - more bindings in environment * NIL - last binding done */ int let_next_binding(int n) { int m, p; m = caddr(Bind_stack); /* rest of environment */ if (m == NIL) return NIL; p = Car[m]; Tmp2 = n; cadr(Bind_stack) = alloc(NIL, cadr(Bind_stack)); caadr(Bind_stack) = alloc(Car[p], n); Tmp2 = NIL; caddr(Bind_stack) = Cdr[m]; return Cdr[m]; } int let_eval_arg(void) { int m, p, v; m = caddr(Bind_stack); p = Car[m]; if ( atomic(p) || Cdr[p] == NIL || atomic(Cdr[p]) || cddr(p) != NIL || !symbolic(Car[p]) ) { /* Error, get rid of the partial environment. */ v = bunsave(1); bunsave(3); bsave(v); Env_stack = unsave(1); save(Function_name); save(Frame); unbind_args(); return error("let/letrec: bad binding", p); } Car[Bind_stack] = alloc(Car[p], Car[Bind_stack]); return cadr(p); } int reverse_in_situ(int n) { int this, next, x; if (n == NIL) return NIL; this = n; next = Cdr[n]; Cdr[this] = NIL; while (next != NIL) { x = Cdr[next]; Cdr[next] = this; this = next; next = x; } return this; } void let_bind(int env) { int b; while (env != NIL) { b = Car[env]; save(cdar(b)); /* Save old value */ cdar(b) = Cdr[b]; /* Bind new value */ env = Cdr[env]; } } int let_finish(int rec) { int m, v, b, e; Tmp2 = alloc(NIL, NIL); /* Create safe storage */ Cdr[Tmp2] = alloc(NIL, NIL); cddr(Tmp2) = alloc(NIL, NIL); cdddr(Tmp2) = alloc(NIL, NIL); v = bunsave(1); b = bunsave(1); /* bindings */ m = bunsave(2); /* drop environment, get full LET/LETREC */ b = reverse_in_situ(b); /* needed for UNBINDARGS() */ e = unsave(1); Car[Tmp2] = b; cadr(Tmp2) = m; caddr(Tmp2) = v; cdddr(Tmp2) = e; let_bind(b); bsave(v); if (rec) fix_cached_closures(); Env_stack = e; save(Function_name); save(Frame); Tmp2 = NIL; return caddr(m); /* term */ } int z_let(int n, int *pcf, int *pmode, int *pcbn) { *pcf = 2; *pmode = MBIND; USE(pcbn); if (let_setup(n) != NIL) return let_eval_arg(); else return NIL; } int z_letrec(int n, int *pcf, int *pmode, int *pcbn) { int m; *pcf = 2; *pmode = MBINR; USE(pcbn); if (let_setup(n) != NIL) m = let_eval_arg(); else m = NIL; Env_stack = S_true; return m; } int z_or(int n, int *pcf, int *pmode, int *pcbn) { USE(pcbn); if (Cdr[n] == NIL) { return S_false; } else if (cddr(n) == NIL) { *pcf = 1; return cadr(n); } else { *pcf = 2; *pmode = MDISJ; return setup_and_or(n); } } int z_quote(int n, int *pcf, int *pmode, int *pcbn) { int m; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); return (Car[m]); } int z_closure_form(int n, int *pcf, int *pmode, int *pcbn) { int m; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); if (!symbolic(Car[m])) return error("closure-form: got non-symbol", Car[m]); if (Car[m] == add_symbol("args", S_void)) Closure_form = 0; else if (Car[m] == add_symbol("body", S_void)) Closure_form = 1; else if (Car[m] == add_symbol("env", S_void)) Closure_form = 2; else return S_false; return Car[m]; } int *Image_vars[] = { &Closure_form, &Verify_arrows, &Symbols, &Freelist, &S_bottom, &S_closure, &S_false, &S_lambda, &S_primitive, &S_quote, &S_special, &S_special_cbv, &S_true, &S_void, &S_last, NULL }; int dump_image(char *p) { int fd, n, i; int **v; char magic[17]; fd = open(p, O_CREAT | O_WRONLY, 0644); setmode(fd, O_BINARY); if (fd < 0) { error("cannot create file", NO_EXPR); Error.arg = p; return -1; } strcpy(magic, "ZEN_____________"); magic[7] = sizeof(int); magic[8] = VERSION; n = 0x12345678; memcpy(&magic[10], &n, sizeof(int)); write(fd, magic, 16); n = Pool_size; write(fd, &n, sizeof(int)); v = Image_vars; i = 0; while (v[i]) { write(fd, v[i], sizeof(int)); i = i+1; } if ( write(fd, Car, Pool_size*sizeof(int)) != Pool_size*sizeof(int) || write(fd, Cdr, Pool_size*sizeof(int)) != Pool_size*sizeof(int) || write(fd, Tag, Pool_size) != Pool_size ) { error("dump failed", NO_EXPR); close(fd); return -1; } close(fd); return 0; } int z_dump_image(int n, int *pcf, int *pmode, int *pcbn) { int m; static char buf[SYMBOL_LEN], *s; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); if (!symbolic(Car[m])) return error("dump-image: got non-symbol", Car[m]); s = symbol_to_string(Car[m], buf, SYMBOL_LEN); if (s) dump_image(s); return S_true; } void get_source_dir(char *path, char *buf) { char *p; if (strlen(path) > 256) { error("load: path too long", NO_EXPR); return; } strcpy(buf, path); p = strrchr(buf, '/'); if (p == NULL) strcpy(buf, "."); else *p = 0; } /* Expand leading ~ in path names */ char *expand_path(char *s, char *buf) { char *r, *v; if (s[0] == '~') r = &s[1]; else return s; if ((v = getenv("ZENSRC")) == NULL) return s; if (strlen(v) + strlen(r) + 4 >= MAX_PATH_LEN) { error("load: path too long", NO_EXPR); return s; } sprintf(buf, "%s/%s", v, r); return buf; } /* Bug: should restore Source_dir after loading a file */ int load(char *p) { FILE *ofile, *nfile; int r; char *oname; char *arg; int oline; arg = p; if (Load_level > 0) { if (strlen(p) + strlen(Source_dir) + 4 >= MAX_PATH_LEN) { error("load: path too long", NO_EXPR); return -1; } if (*p != '.' && *p != '/' && *p != '~') sprintf(Current_path, "%s/%s", Source_dir, p); else strcpy(Current_path, p); p = Current_path; } p = expand_path(p, Expanded_path); get_source_dir(p, Source_dir); strcat(p, ".l"); if ((nfile = fopen(p, "r")) == NULL) { error("cannot open source file", NO_EXPR); Error.arg = arg; return -1; } Load_level = Load_level + 1; /* Save I/O state and redirect */ r = Rejected; ofile = Input; Input = nfile; oline = Line; Line = 1; oname = Infile; Infile = p; read_eval_loop(); Infile = oname; Line = oline; /* Restore previous I/O state */ Rejected = r; Input = ofile; Load_level = Load_level - 1; fclose(nfile); if (Paren_level) error("unbalanced parentheses in loaded file", NO_EXPR); return 0; } int z_load(int n, int *pcf, int *pmode, int *pcbn) { int m; char buf[SYMBOL_LEN+1], *s; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); if (!symbolic(Car[m])) return error("load: got non-symbol", Car[m]); s = symbol_to_string(Car[m], buf, SYMBOL_LEN); if (s) { s = strdup(s); if (s == NULL) fatal("load: strdup() failed"); load(s); free(s); } return S_true; } int z_stats(int n, int *pcf, int *pmode, int *pcbn) { int m; char buf[100]; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL || Cdr[m] != NIL) return wrong_arg_count(n); reset_counter(&Allocations); reset_counter(&Reductions); reset_counter(&Collections); Stat_flag = 1; n = eval(Car[m]); Stat_flag = 0; n = alloc(n, NIL); save(n); Cdr[n] = alloc(NIL, NIL); cadr(n) = explode_string(counter_to_string(&Reductions, buf)); cddr(n) = alloc(NIL, NIL); caddr(n) = explode_string(counter_to_string(&Allocations, buf)); cdddr(n) = alloc(NIL, NIL); cadddr(n) = explode_string(counter_to_string(&Collections, buf)); unsave(1); return n; } int z_trace(int n, int *pcf, int *pmode, int *pcbn) { int m; static char buf[SYMBOL_LEN], *s; USE(pcf); USE(pmode); USE(pcbn); m = Cdr[n]; if (m == NIL) { Traced_fn = NIL; return S_true; } if (Cdr[m] != NIL) return wrong_arg_count(n); if (!symbolic(Car[m])) return error("trace: got non-symbol", Car[m]); s = symbol_to_string(Car[m], buf, SYMBOL_LEN); if (!s) return S_false; Traced_fn = find_symbol(s); return S_true; } /* If (CAR NP[0]) is a special form handler, run it. */ int special(int *np, int *pcf, int *pmode, int *pcbn) { int n, y; int (*op)(int, int *, int *, int *); n = np[0]; y = Car[n]; if (Error_flag) return 0; if (Car[y] == S_special || Car[y] == S_special_cbv) op = Specials[cadr(y)]; else if (symbolic(y) && (cadr(y) == S_special || cadr(y) == S_special_cbv) ) op = Specials[caddr(y)]; else return 0; np[0] = (*op)(n, pcf, pmode, pcbn); return 1; } /* * Bind the arguments of a LAMBDA function. * For a lambda application N=((LAMBDA (X1 ... Xn) S [ENV]) Y1 ... Yn) * this includes the following steps for j in {1,...,n}: * 1) add Xj to Car[Bind_stack] * 2) save the value of Xj * 3) bind Xj to Yj */ void bind_args(int n, int name) { int fa, /* formal arg list */ aa, /* actual arg list */ e; /* term */ int env; /* optional lexical environment */ int p; int at; /* atomic argument list flag */ if (Error_flag) return; fa = cadar(n); at = symbolic(fa); aa = Cdr[n]; p = cddar(n); e = Car[p]; env = Cdr[p] != NIL ? cadr(p): NIL; bsave(NIL); /* names */ while ((fa != NIL && aa != NIL) || at) { if (!at) { Car[Bind_stack] = alloc(Car[fa], Car[Bind_stack]); save(cdar(fa)); cdar(fa) = Car[aa]; fa = Cdr[fa]; aa = Cdr[aa]; } if (symbolic(fa)) { Car[Bind_stack] = alloc(fa, Car[Bind_stack]); save(Cdr[fa]); Cdr[fa] = aa; fa = NIL; aa = NIL; break; } } while (env != NIL) { p = Car[env]; Car[Bind_stack] = alloc(Car[p], Car[Bind_stack]); save(cdar(p)); cdar(p) = Cdr[p]; env = Cdr[env]; } if (fa != NIL || aa != NIL) { wrong_arg_count(n); n = NIL; } else { n = e; } save(Function_name); Function_name = name; save(Frame); Frame = Stack; } void print_trace(int n) { pr("+ "); pr("("); Quotedprint = 1; print(Traced_fn); while (1) { n = Cdr[n]; if (n == NIL) break; pr(" "); print(Car[n]); } pr(")"); nl(); } void eliminate_tail_calls(void) { int m, y; m = Car[Mode_stack]; /* Skip over callee's local frames, if any */ while (m != NIL && Car[m] == MLETR) { m = Cdr[m]; } /* Parent not beta-reducing? Give up. */ if (m == NIL || Car[m] != MBETA) return; /* Yes, this is a tail call: */ /* remove callee's frames. */ while (1) { Tmp2 = unsave(1); /* M */ unbind_args(); unsave(1); y = munsave(); save(Tmp2); Tmp2 = NIL; if (y == MBETA) break; } } /* Evaluate the term N and return its normal form. */ int eval(int n) { int m, /* Result node */ m2, /* Root of result lists */ a; /* Used to append to result */ int mode, /* Current state */ cf, /* Continue flag */ cbn; /* Call by name flag */ int nm; /* Name of function to apply */ Eval_level = Eval_level + 1; save(n); save(Arg_stack); save(Bind_stack); save(Car[Mode_stack]); save(Stack_bottom); Stack_bottom = Stack; mode = MATOM; cf = 0; cbn = 0; while (!Error_flag) { if (Stat_flag) count(&Reductions, 1); if (n == NIL) { /* () -> () */ m = NIL; cbn = 0; } else if (symbolic(n)) { /* Symbol -> Value */ if (cbn) { m = n; cbn = 0; } else { m = Cdr[n] == Car[n]? n: Cdr[n]; if (m == S_void) { error("symbol not bound", n); break; } } } else if (Car[n] == S_closure || Car[n] == S_primitive || Car[n] == S_special || Car[n] == S_special_cbv || cbn == 2 ) { m = n; cbn = 0; } else { /* List (...) and Pair (X.Y) */ /* * This block is used to descend into lists. * The following nodes/variables will be saved: * 1) the original list (on Stack) * 2) the current state (on Mode_stack) * 3) the root of the result list (on Arg_stack) * 4) a ptr to the next free node * in the result list (on Arg_stack) * 5) a ptr to the next member of * the original list (on Arg_stack) */ m = Car[n]; save(n); msave(mode); if ((symbolic(m) && cadr(m) == S_special) || cbn) { cbn = 0; asave(NIL); asave(NIL); asave(n); /* Root of result list */ n = NIL; } else { a = alloc(NIL, NIL); asave(a); asave(Cdr[n]); asave(a); /* Root of result list */ n = Car[n]; } mode = MLIST; continue; } /* * The following loop is used to ascend back to the * root of a list, thereby performing BETA reduction * and creating result lists. */ while (1) if (mode == MBETA || mode == MLETR) { /* Finish BETA reduction */ unbind_args(); unsave(1); mode = munsave(); } else if (mode == MLIST) { n = cadr(Arg_stack); /* Next member */ a = caddr(Arg_stack); /* Place to append to */ m2 = aunsave(1); /* Root of result list */ if (a != NIL) Car[a] = m; if (n == NIL) { /* End of list */ m = m2; aunsave(2); /* Drop N,A */ nm = Car[unsave(1)]; save(m); /* Save result */ if (Traced_fn == nm) print_trace(m); if (primitive(&m)) ; else if (special(&m, &cf, &mode, &cbn)) n = m; else if (!atomic(Car[m]) && caar(m) == S_closure ) { nm = symbolic(nm)? nm: NIL; eliminate_tail_calls(); bind_args(m, nm); /* N=E of ((LAMBDA (...) E) ...) */ n = caddar(m); cf = 2; mode = MBETA; } else { error("application of non-function", nm); n = NIL; } if (cf != 2) { unsave(1); mode = munsave(); } /* Leave the list loop and re-evaluate N */ if (cf) break; } else { /* N =/= NIL: Append to list */ asave(m2); Cdr[a] = alloc(NIL, NIL); caddr(Arg_stack) = Cdr[a]; cadr(Arg_stack) = Cdr[n]; if (symbolic(n)) error("improper list in application", n); n = Car[n]; /* Evaluate next member */ break; } } else if (mode == MCOND) { n = cond_eval_clause(m); if (Car[Bind_stack] == NIL) { unsave(1); bunsave(1); mode = munsave(); } cf = 1; break; } else if (mode == MCONJ || mode == MDISJ) { Car[Bind_stack] = cdar(Bind_stack); if ( (m == S_false && mode == MCONJ) || (m != S_false && mode == MDISJ) || Car[Bind_stack] == NIL ) { unsave(1); bunsave(1); mode = munsave(); n = m; cbn = 2; } else if (cdar(Bind_stack) == NIL) { n = caar(Bind_stack); unsave(1); bunsave(1); mode = munsave(); } else { n = caar(Bind_stack); } cf = 1; break; } else if (mode == MBIND || mode == MBINR) { if (let_next_binding(m) == NIL) { n = let_finish(mode == MBINR); mode = MLETR; } else { n = let_eval_arg(); } cf = 1; break; } else { /* Atom */ break; } if (cf) { /* Continue evaluation if requested */ cf = 0; continue; } if (Stack == Stack_bottom) break; } while (Stack != Stack_bottom) unsave(1); Stack_bottom = unsave(1); Car[Mode_stack] = unsave(1); Bind_stack = unsave(1); Arg_stack = unsave(1); unsave(1); Eval_level = Eval_level - 1; return m; } /* Print (QUOTE X) as 'X */ int print_quoted_form(int n, int dot) { if ( Car[n] == S_quote && Cdr[n] != NIL && cddr(n) == NIL ) { if (dot) pr(" . "); n = cadr(n); if (n != S_true && n != S_false) pr("'"); print(n); return 1; } return 0; } int print_condensed_list(int n, int dot) { int m; char s[2]; m = n; if (m == NIL) return 0; while (m != NIL) { if (!symbolic(Car[m])) return 0; if (cdaar(m) != NIL) return 0; m = Cdr[m]; } if (dot) pr(" . "); pr("#"); m = n; s[1] = 0; while (m != NIL) { s[0] = caaar(m); pr(s); m = Cdr[m]; } return 1; } int print_closure(int n, int dot) { if ( Car[n] == S_closure && !atomic(Cdr[n]) && !atomic(cddr(n)) ) { Quotedprint = 1; if (dot) pr(" . "); pr(Closure_form==2? "(closure ": "{closure "); print(cadr(n)); if (Closure_form > 0) { pr(" "); print(caddr(n)); if (Closure_form > 1 && cdddr(n) != NIL) { pr(" "); print(cadddr(n)); } } pr(Closure_form==2? ")": "}"); return 1; } return 0; } int print_primitive(int n, int dot) { if ( Car[n] != S_primitive && Car[n] != S_special && Car[n] != S_special_cbv ) return 0; if (dot) pr(" . "); pr("{internal "); Quotedprint = 1; print(cddr(n)); pr("}"); return 1; } void print(int n) { char s[SYMBOL_LEN+1]; int i; if (n == NIL) { pr("()"); } else if (n == S_void) { pr("{void}"); } else if (Tag[n] & ATOM_FLAG) { /* Characters are limited to the symbol table */ pr("{unprintable form}"); } else if (symbolic(n)) { if (!Quotedprint && n != S_true && n != S_false) { pr("'"); Quotedprint = 1; } i = 0; /* Symbol */ n = Car[n]; while (n != NIL) { s[i] = Car[n]; if (i > SYMBOL_LEN-2) break; i += 1; n = Cdr[n]; } s[i] = 0; pr(s); } else { /* List */ if (print_closure(n, 0)) return; if (print_primitive(n, 0)) return; if (!Quotedprint) { pr("'"); Quotedprint = 1; } if (print_quoted_form(n, 0)) return; if (print_condensed_list(n, 0)) return; pr("("); while (n != NIL) { print(Car[n]); n = Cdr[n]; if (symbolic(n) || n == S_void) { pr(" . "); print(n); n = NIL; } if (print_closure(n, 1)) break; if (print_primitive(n, 1)) break; if (print_quoted_form(n, 1)) break; if (n != NIL) pr(" "); } pr(")"); } } void reset_state(void) { Stack = NIL; Arg_stack = NIL; Bind_stack = NIL; Env_stack = NIL; Frame = NIL; Function_name = NIL; Eval_level = 0; Paren_level = 0; } /* Initialize interpreter variables. */ void init1() { /* Misc. variables */ reset_state(); Mode_stack = NIL; Error_flag = 0; Error.arg = NULL; Fatal_flag = 0; Symbols = NIL; Safe_symbols = NIL; Tmp_car = NIL; Tmp_cdr = NIL; Tmp = NIL; Tmp2 = NIL; Load_level = 0; Traced_fn = NIL; Max_atoms_used = 0; Max_trace = 10; Stat_flag = 0; Closure_form = 0; Verify_arrows = 0; Line = 1; /* Initialize Freelist */ Freelist = NIL; /* Clear input buffer */ Infile = NULL; Source_dir[0] = 0; Input = stdin; Output = stdout; Rejected = EOT; } /* * Second stage of initialization: * build the free list, * create built-in symbols. */ void init2(void) { /* * Create builtin symbols. * Tags (especially 'primitive and 'special*) * must be defined before any primitives. * First GC will be triggered HERE */ S_void = add_symbol("{void}", 0); S_special = add_symbol("{special}", 0); S_special_cbv = add_symbol("{special/cbv}", 0); S_primitive = add_symbol("{primitive}", 0); S_closure = add_symbol("closure", 0); add_primitive("atom", P_ATOM); add_special("and", SF_AND, 0); add_special("apply", SF_APPLY, 1); S_bottom = add_primitive("bottom", P_BOTTOM); add_primitive("car", P_CAR); add_primitive("cdr", P_CDR); add_special("closure-form", SF_CLOSURE_FORM, 0); add_special("cond", SF_COND, 0); add_primitive("cons", P_CONS); add_special("define", SF_DEFINE, 0); add_primitive("defined", P_DEFINED); add_special("dump-image", SF_DUMP_IMAGE, 0); add_special("eval", SF_EVAL, 1); add_primitive("eq", P_EQ); add_primitive("explode", P_EXPLODE); S_false = add_symbol(":f", 0); add_primitive("gc", P_GC); add_primitive("implode", P_IMPLODE); S_lambda = add_special("lambda", SF_LAMBDA, 0); add_special("let", SF_LET, 0); add_special("letrec", SF_LETREC, 0); add_special("load", SF_LOAD, 0); add_special("or", SF_OR, 0); add_primitive("quit", P_QUIT); S_quote = add_special("quote", SF_QUOTE, 0); add_primitive("recursive-bind", P_RECURSIVE_BIND); add_special("stats", SF_STATS, 0); add_primitive("symbols", P_SYMBOLS); S_true = add_symbol(":t", 0); add_symbol("t", S_true); add_special("trace", SF_TRACE, 0); add_primitive("verify-arrows", P_VERIFY_ARROWS); S_last = add_symbol("**", 0); Mode_stack = alloc(NIL, NIL); Primitives[P_ATOM] = &z_atom; Primitives[P_BOTTOM] = &z_bottom; Primitives[P_CAR] = &z_car; Primitives[P_CDR] = &z_cdr; Primitives[P_CONS] = &z_cons; Primitives[P_DEFINED] = &z_defined; Primitives[P_EQ] = &z_eq; Primitives[P_EXPLODE] = &z_explode; Primitives[P_GC] = &z_gc; Primitives[P_IMPLODE] = &z_implode; Primitives[P_QUIT] = &z_quit; Primitives[P_RECURSIVE_BIND] = &z_recursive_bind; Primitives[P_SYMBOLS] = &z_symbols; Primitives[P_VERIFY_ARROWS] = &z_verify_arrows; Specials[SF_AND] = &z_and; Specials[SF_APPLY] = &z_apply; Specials[SF_CLOSURE_FORM] = &z_closure_form; Specials[SF_COND] = &z_cond; Specials[SF_DEFINE] = &z_define; Specials[SF_DUMP_IMAGE] = &z_dump_image; Specials[SF_EVAL] = &z_eval; Specials[SF_LAMBDA] = &z_lambda; Specials[SF_LET] = &z_let; Specials[SF_LETREC] = &z_letrec; Specials[SF_LOAD] = &z_load; Specials[SF_OR] = &z_or; Specials[SF_QUOTE] = &z_quote; Specials[SF_STATS] = &z_stats; Specials[SF_TRACE] = &z_trace; } void clear_stats(void) { reset_counter(&Reductions); reset_counter(&Allocations); reset_counter(&Collections); } int zen_load_image(char *p) { int fd, n, i; char buf[17]; int **v; int bad = 0; int inodes; fd = open(p, O_RDONLY); setmode(fd, O_BINARY); if (fd < 0) { error("cannot open image", NO_EXPR); Error.arg = p; return -1; } memset(Tag, 0, Pool_size); read(fd, buf, 16); if (memcmp(buf, "ZEN____", 7)) { error("bad image (magic match failed)", NO_EXPR); bad = 1; } if (buf[7] != sizeof(int)) { error("bad image (wrong cell size)", NO_EXPR); bad = 1; } if (buf[8] != VERSION) { error("bad image (wrong version)", NO_EXPR); bad = 1; } memcpy(&n, &buf[10], sizeof(int)); if (n != 0x12345678) { error("bad image (wrong architecture)", NO_EXPR); bad = 1; } read(fd, &inodes, sizeof(int)); if (inodes > Pool_size) { error("bad image (too many nodes)", NO_EXPR); bad = 1; } v = Image_vars; i = 0; while (v[i]) { read(fd, v[i], sizeof(int)); i = i+1; } if ( !bad && (read(fd, Car, inodes*sizeof(int)) != inodes*sizeof(int) || read(fd, Cdr, inodes*sizeof(int)) != inodes*sizeof(int) || read(fd, Tag, inodes) != inodes) ) { error("bad image (bad file size)", NO_EXPR); bad = 1; } close(fd); if (bad) Error.arg = p; return Error_flag; } int zen_init(int nodes, int vgc) { Pool_size = nodes? nodes: DEFAULT_NODES; Verbose_GC = vgc; if (Pool_size < MINIMUM_NODES) return -1; if ( (Car = (int *) malloc(Pool_size * sizeof(int))) == NULL || (Cdr = (int *) malloc(Pool_size * sizeof(int))) == NULL || (Tag = (char *) malloc(Pool_size)) == NULL ) { if (Car) free(Car); if (Cdr) free(Cdr); if (Tag) free(Tag); Car = Cdr = NULL; Tag = NULL; return -1; } memset(Tag, 0, Pool_size); init1(); init2(); return 0; } void zen_fini() { if (Car) free(Car); if (Cdr) free(Cdr); if (Tag) free(Tag); Car = Cdr = NULL; Tag = NULL; } void zen_stop(void) { error("interrupted", NO_EXPR); } void zen_print(int n) { Quotedprint = 0; print(n); } int zen_read(void) { Paren_level = 0; return zread(); } int copy_bindings(void) { int y, p, ny, q; p = alloc(NIL, NIL); save(p); ny = p; q = NIL; y = Symbols; while (y != NIL) { Car[p] = alloc(Car[y], cdar(y)); y = Cdr[y]; Cdr[p] = alloc(NIL, NIL); q = p; p = Cdr[p]; } if (q != NIL) Cdr[q] = NIL; unsave(1); return Car[ny] == NIL? NIL: ny; } void restore_bindings(int values) { int b; while (values != NIL) { b = Car[values]; cdar(b) = Cdr[b]; values = Cdr[values]; } } /* Safely evaluate an expression. */ int zen_eval(int n) { save(n); Safe_symbols = copy_bindings(); if (Stat_flag) clear_stats(); n = eval(n); unsave(1); if (!Error_flag) { Cdr[S_last] = n; if (Stack != NIL) fatal("eval(): unbalanced stack"); } else { restore_bindings(Safe_symbols); } reset_state(); while (Car[Mode_stack] != NIL) munsave(); return n; } char **zen_license() { static char *license_text[] = { "", "zenlisp -- An interpreter for symbolic LISP", "By Nils M Holm, 2007, 2008, 2013", "", "Don't worry, be happy.", "", "THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND", "ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE", "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE", "ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE", "FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL", "DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS", "OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)", "HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT", "LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY", "OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF", "SUCH DAMAGE.", "", NULL}; return license_text; } void read_eval_loop(void) { int n, evl; Error_flag = 0; evl = Eval_level; Eval_level = 0; while(!Error_flag) { n = zen_read(); if (n == EOT) break; n = eval(n); } Eval_level = evl; } #include char Image[MAX_PATH_LEN]; int Nodes; int Batch; int GC_stats; void usage(void) { fprintf(stderr, "Usage: zl [-L] [-bgi] [-n nodes] [image]\n"); } int get_opt_val(int argc, char **argv, int *pi, int *pj, int *pk) { int n, c; if (++(*pi) >= argc) { usage(); exit(1); } n = atoi(argv[*pi]); c = argv[*pi][strlen(argv[*pi])-1]; switch (c) { case 'K': n = n * 1024; break; case 'M': n = n * 1024 * 1024; break; } *pj = *pk = 0; return n; } void help(void) { fputc('\n', stderr); usage(); fprintf(stderr, "\n" "-b batch mode (quiet, exit on first error)\n" "-g report number of free nodes after each GC\n" "-i init mode (do not load any image)\n" "-n # number of nodes to allocate (default: %dK)\n" "-L print license and exit\n" "\n" "default image: %s\n\n", DEFAULT_NODES/1024, DEFAULT_IMAGE); } void print_license(void) { char **s; s = zen_license(); while (*s) { printf("%s\n", *s); s++; } exit(0); } void get_options(int argc, char **argv) { char *a; int i, j, k; int v; strncpy(Image, DEFAULT_IMAGE, strlen(DEFAULT_IMAGE)); Image[MAX_PATH_LEN-1] = 0; Nodes = DEFAULT_NODES; GC_stats = 0; Batch = 0; v = 0; i = 1; while (i < argc) { a = argv[i]; if (a[0] != '-') break; k = strlen(a); for (j=1; j "); zen_print(n); nl(); } } } void init(void) { if (zen_init(Nodes, GC_stats)) { fprintf(stderr, "zenlisp init failed (memory problem)\n"); exit(1); } } int main(int argc, char **argv) { get_options(argc, argv); init(); get_options(argc, argv); if (!Batch) { pr("zenlisp "); pr(RELEASE); pr(" by Nils M Holm"); nl(); } if (Image[0]) { if (zen_load_image(Image)) { zen_print_error(); if (Batch) exit(1); zen_fini(); init(); get_options(argc, argv); } } else if (!Batch) { pr("Warning: no image loaded"); nl(); } signal(SIGINT, catch_int); repl(); zen_fini(); return 0; } zenlisp-2013.11.22/debian/0000775000175000017500000000000012267235017013742 5ustar barakbarak