fulton
/
nwlisp
mirror of https://git.sr.ht/~fultonbrowne/lispything
1
1
Fork 0
Code Issues Projects Releases Wiki Activity

init commit

This commit is contained in:
Fulton Browne 2021-08-01 15:43:21 -07:00
commit 68ade6208d
24 changed files with 14430 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
Changes Normal file
View File

@ -0,0 +1,75 @@
"LISP System Implementation", post-publication changes
[!] indicates changes that break compatibility with the book version
20200220
Fixed a mistake in the description of IF*. Thanks, Brian!
20191221
Fixed various typos in the reference manual. Thanks to
Wojciech Gac for pointing them out!
20190812
string(Obmap) could be undefined in gc().
20190804
Fixed GC leak in intern() function.
20190728
Corrected formal grammar (lisp9.txt), added RENAME test to
test suite.
20190726
Added new opcodes (FLUSH, RENAME) to the disassembler.
20190724
Made WITH-INFILE and WITH-OUTFILE restore the previous current
I/O port when exiting their dynamic extent via non-local exit.
Made WITH-INPORT and WITH-OUTPORT close their respective file
when exiting their dynamic extent via non-local exit.
20190719
Added RENAME function for renaming files.
20190711
Added FLUSH function for writing pending output to ports.
20190705
Reset error handler (*Errtag*) in the REPL.
20190627
Even though the result if SYMNAME is constant, it still has
to copy the name, because vector atoms cannot share their
payloads.
20190626 [!]
Comments are now the usual, non-persistent, reader-level
comments. It was a nice experiment, but in the end comments
as objects caused more trouble than benefit.
20190626
Reference trace printed in wrong order in error messages.
20190617 [!]
SYMNAME returns an immutable string now.
20190615
vector(Obarray) could be undefined in gc().
Thanks, Alexander Shendi!
20190613
Added README.
Thanks, Harsh Raju Chamarthi!
20190610
Sending SIGINT while running an image via START drops you to
the REPL. Did exit LISP9 before.
20190603
Fixed GC leak in cons3() with ptag==CONST_TAG.
20190603
veclen(Obarray) could be undefined in gc().
Thanks, Alexander Shendi!

55
Makefile Normal file
View File

@ -0,0 +1,55 @@
A=lisp9.tgz
R=lisp9-20200220.tgz
CFLAGS= -g -O2
all: ls9 ls9.image # prolog # lisp9.ps
ls9: ls9.c
$(CC) $(CFLAGS) -o ls9 ls9.c
ls9.image: ls9 ls9.ls9
rm -f ls9.image
echo "(dump-image \"ls9.image\")" | ./ls9 -q
echo "(save)" | ./ls9 -l src/help.ls9 -l src/disasm.ls9 -l src/grind.ls9 -l src/repl.ls9
lisp9.tr: lisp9.txt
./ls9 src/print.ls9 -T -C -p 60 -l 6 -m -4 -t "LISP9 REFERENCE MANUAL" \
lisp9.txt >lisp9.tr
lisp9.ps: lisp9.tr
groff -Tps -P-p11i,8.5i lisp9.tr >lisp9.ps
test: ls9 ls9.image
./ls9 test.ls9
ptest: ls9 prolog
./ls9 -i prolog -- -q <src/test.pl9 > src/test.out
diff -u src/test.OK src/test.out && rm src/test.out
zebra: ls9 prolog src/zebra.pl9
echo "prlist([])." \
"prlist([H|T]) :- write(H), nl, prlist(T)." \
":- nl, zebra(H), !, prlist(H), fail." \
| ./ls9 -i prolog -- -q -c src/zebra.pl9
prolog: ls9 src/prolog.ls9 src/prolog.pl9
echo "(defun (start) (prolog) (quit)) (dump-image \"prolog\")" \
| ./ls9 -ql src/prolog.ls9
arc: clean
tar cf - * | gzip -c9 >$A
dist: clean
cd ..; tar -cvf - `cat lisp9/_nodist` lisp9 | gzip -9c >$R
mv ../$R .
csums:
csum -u <_csums >_csums.new
mv _csums.new _csums
mksums: clean
find . -type f | grep -v _csums |grep -v $A | csum >_csums
clean:
rm -f ls9 ls9.image *.oimage prolog lisp9.ps lisp9.tr lisp9.ps \
$A $R a.out *.core

4
Notes Normal file
View File

@ -0,0 +1,4 @@
? strnum should parse #nR
structure editor

63
README Normal file
View File

@ -0,0 +1,63 @@
LISP9 -- an experimental LISP system
Nils M Holm, 2018, 2019
In the public domain.
If your country does not have a concept like the public
domain, the Creative Common Zero (CC0) licence applies.
See https://creativecommons.org/publicdomain/zero/1.0/
In order to build LISP9, an ANSI C89 / ISO C90 compiler is
needed. In addition, the rename() system call has to be
present, but it can be removed from the code without any
consequences other than the RENAME function not working.
To build the LISP9 system, run "make". Without make, run
cc -O2 -o ls9 ls9.c
echo '(dump-image "ls9.image")' | ./ls9 -q
To make sure that the system works properly, run "make test"
or "./ls9 test.ls9".
For a summary of command line options, run "./ls9 -h".
To build an image containing the online help system, run
echo "(save)" | ./ls9 -l src/help.ls9
When starting LISP9 for the next time, you can then use
,h,t to view the table of contents
,h,t chapter to view the contents of a chapter
,h topic to view the section about a given topic
To build an image containing the online help system, the
LAM disassembler, and the pretty printer (grinder), run
echo "(save)" | \
./ls9 -l src/help.ls9 -l src/disasm.ls9 -l src/grind.ls9 -l src/repl.ls9
To start the interpreter in interactive mode, run
./ls9
The interpreter prompt is a single "*". Expressions typed at
the prompt will evaluate and print their results. The most
recently printed result will be bound to the variable **, so
you can reuse the result without typing it, e.g.:
* (mapcar list '(a b c) '(1 2 3))
((a 1) (b 2) (c 3))
* (assq 'b **)
(b 2)
There are a few shortcuts that work only on the REPL:
,c command will pass "command" to the shell
,h topic will display sections of the manual (see above)
,l file will load "file.ls9".
To end a LISP9 session, send an EOF marker (control-D on Unix)
to the system or enter (quit).

29
_csums Normal file
View File

@ -0,0 +1,29 @@
11981 2 ./Makefile
53964 1 ./Notes
39716 2 ./README
51736 109 ./ls9.c
50427 20 ./ls9.ls9
62016 61 ./test.ls9
29837 1 ./_nodist
22069 2 ./Changes
50958 110 ./lisp9.txt
42503 5 ./cover.ps
7095 1 ./src/array.ls9
54773 19 ./src/boyer.ls9
52587 1 ./src/ctak.ls9
47196 6 ./src/disasm.ls9
22523 11 ./src/grind.ls9
13935 2 ./src/hash.ls9
26170 4 ./src/help.ls9
6616 1 ./src/ltak.ls9
54934 4 ./src/meta.ls9
49080 1 ./src/nreconc.ls9
26599 6 ./src/print.ls9
22774 53 ./src/prolog.ls9
48668 1 ./src/start.ls9
65089 2 ./src/zebra.pl9
35990 1 ./src/iota.ls9
3035 14 ./src/test.pl9
34152 1 ./src/prolog.pl9
13977 17 ./src/test.OK
34603 3 ./src/examples.pl9

113
cover.ps Normal file
View File

@ -0,0 +1,113 @@
%!PS-Adobe-3.0
%%Creator: NMH
%%DocumentMedia: Plain 1242 810 0 white ()
%%PageOrder: Ascend
%%LanguageLevel: 2
%%BoundingBox: 0 0 1242 810
%%EndComments
0.0 0.25 0.0 setrgbcolor
0 0 moveto 1281 0 lineto 1281 809 lineto 0 809 lineto 0 0 lineto fill
/scale 1.4 def
/xpos 670 def
/ypos 500 def
/rl { exch scale mul exch scale mul rlineto } def
/rm { exch scale mul exch scale mul rmoveto } def
/lisp {
70 0 rl 20 40 rl -30 0 rl 30 60 rl -40 0 rl -50 -100 rl
70 0 rm 50 100 rl 40 0 rl -50 -100 rl -40 0 rl
40 0 rm 20 40 rl 20 0 rl -10 20 rl 20 40 rl 70 0 rl
-20 -40 rl -20 0 rl 10 -20 rl -20 -40 rl -70 0 rl
70 0 rm 20 40 rl 10 20 rm 20 40 rl 70 0 rl -30 -60 rl
-20 0 rl -20 -40 rl -50 0 rl
70 0 rm 30 60 rm 20 40 rl 50 0 rl 20 -40 rl -30 -60 rl
-50 0 rl 20 40 rl -20 0 rl -10 20 rl
} def
1 setlinecap
7 setlinewidth
0 0.15 0 setrgbcolor
xpos ypos moveto
lisp fill
0.0 1.0 0 setrgbcolor
xpos ypos moveto
lisp stroke
/sp { 1.25 0 rm } def
/a { 0 5 rl 1 1 rl 1 0 rl 1 -1 rl 0 -2 rl -3 0 rl 3 0 rl 0 -3 rl sp } def
/b { 0 6 rl 2 0 rl 1 -1 rl 0 -2 rl -3 0 rl 2 0 rl 1 -1 rl 0 -2 rl -3 0 rl
3 0 rm sp } def
/c { 3 1 rm -1 -1 rl -1 0 rl -1 1 rl 0 4 rl 1 1 rl 1 0 rl 1 -1 rl 0 -5 rm
sp } def
/d { 0 6 rl 2 0 rl 1 -1 rl 0 -4 rl -1 -1 rl -2 0 rl 3 0 rm sp } def
/e { 0 6 rl 3 0 rl -3 -3 rm 2 0 rl -2 0 rm 0 -3 rl 3 0 rl sp } def
/f { 0 6 rl 3 0 rl -3 -3 rm 2 0 rl -2 0 rm 0 -3 rl 3 0 rm sp } def
/g { 1 3 rm 2 0 rl 0 -2 rl -1 -1 rl -1 0 rl -1 1 rl 0 4 rl 1 1 rl 1 0 rl
1 -1 rl 0 -5 rm sp } def
/h { 0 6 rl 0 0 rm 0 -3 rl 3 0 rl 0 3 rl 0 0 rm 0 -6 rl sp } def
/i { 3 0 rl 0 0 rm -1.5 0 rl 0 6 rl -1.5 0 rl 0 0 rm 3 0 rl 0 -6 rm sp } def
/j { 0 6 rm 3 0 rm 0 -5 rl -1 -1 rl -1 0 rl -1 1 rl 3 -1 rm sp } def
/k { 0 6 rl 0 0 rm 0 -2 rl 3 -3 rl 0 -1 rl -3 3 rm 3 3 rl 0 -6 rm sp } def
/l { 0 6 rl 0 0 rm 0 -6 rl 3 0 rl sp } def
/m { 0 6 rl 0 0 rm 1.5 -1.5 rl 1.5 1.5 rl 0 0 rm 0 -6 rl sp } def
/n { 0 6 rl 0 0 rm 0 -1 rl 3 -4 rl 0 5 rl 0 0 rm 0 -6 rl sp } def
/o { 0 1 rm 0 4 rl 1 1 rl 1 0 rl 1 -1 rl 0 -4 rl -1 -1 rl -1 0 rl -1 1 rl
3 -1 rm sp } def
/p { 0 6 rl 2 0 rl 1 -1 rl 0 -1 rl -1 -1 rl -2 0 rl 3 -3 rm sp } def
/q { 0 1 rm 0 4 rl 1 1 rl 1 0 rl 1 -1 rl 0 -4 rl -1 -1 rl -1 0 rl -1 1 rl
2 0 rm 1 -1 rl sp } def
/r { 0 6 rl 2 0 rl 1 -1 rl 0 -1 rl -1 -1 rl -2 0 rl 1 0 rm 2 -3 rl sp } def
/s { 3 5 rm -1 1 rl -1 0 rl -1 -1 rl 0 -1 rl 1 -1 rl 1 0 rl 1 -1 rl 0 -1 rl
-1 -1 rl -1 0 rl -1 1 rl 3 -1 rm sp } def
/t { 1.5 0 rm 0 6 rl -1.5 0 rl 0 0 rm 3 0 rl 0 -6 rm sp } def
/u { 1 0 rm -1 1 rl 0 5 rl 1 -6 rm 1 0 rl 1 1 rl 0 5 rl 0 -6 rm sp } def
/v { 1.5 0 rm -1.5 2 rl 0 4 rl 1.5 -6 rm 1.5 2 rl 0 4 rl 0 -6 rm sp } def
/w { 0 6 rl 0 -6 rm 1.5 1.5 rl 0 0 rm 1.5 -1.5 rl 0 0 rm 0 6 rl 0 -6 rm
sp } def
/x { 0 1 rl 3 4 rl 0 1 rl -3 0 rm 0 -1 rl 3 -4 rl 0 -1 rl sp } def
/y { 1.5 0 rm 0 3 rl -1.5 1.5 rl 0 1.5 rl 3 0 rm 0 -1.5 rl -1.5 -1.5 rl
1.5 -3 rm sp } def
/z { 0 6 rm 3 0 rl 0 -1 rl -3 -4 rl 0 -1 rl 3 0 rl sp } def
/d0 { 0 1 rm 0 4 rl 1 1 rl 1 0 rl 1 -1 rl 0 -4 rl -1 -1 rl -1 0 rl -1 1 rl
1 -1 rm 1 6 rl 1 -6 rm sp } def
/d1 { 3 0 rl -1.5 0 rm 0 6 rl -1.5 -1.5 rl 3 -4.5 rm sp } def
/d2 { 3 0 rl -3 0 rm 0 1 rl 3 3 rl 0 1 rl -1 1 rl -1 0 rl -1 -1 rl 3 -5 rm
sp } def
/d3 { 0 5 rm 1 1 rl 1 0 rl 1 -1 rl 0 -1 rl -1 -1 rl -1 0 rl 1 0 rm 1 -1 rl
0 -1 rl -1 -1 rl -1 0 rl -1 1 rl 3 -1 rm sp } def
/d4 { 0 3 rm 0 3 rl 0 -3 rm 3 0 rl 0 3 rl 0 0 rm 0 -6 rl sp } def
/d5 { 3 6 rm -3 0 rl 0 -3 rl 2 0 rl 1 -1 rl 0 -1 rl -1 -1 rl -1 0 rl -1 1 rl
3 -1 rm sp } def
/d6 { 3 5 rm -1 1 rl -1 0 rl -1 -1 rl 0 -2 rl 2 0 rl 1 -1 rl 0 -1 rl -1 -1 rl
-1 0 rl -1 1 rl 0 2 rl 3 -3 rm sp } def
/d7 { 0 6 rm 3 0 rl 0 -1 rl -3 -5 rl 3 0 rm sp } def
/d8 { 0 1 rm 0 1 rl 1 1 rl 1 0 rl 1 -1 rl 0 -1 rl -1 -1 rl -1 0 rl -1 1 rl
1 2 rm -1 1 rl 0 1 rl 1 1 rl 1 0 rl 1 -1 rl 0 -1 rl -1 -1 rl 1 -3 rm
sp } def
/d9 { 3 3 rm -2 0 rl -1 1 rl 0 1 rl 1 1 rl 1 0 rl 1 -1 rl 0 -4 rl -1 -1 rl
-1 0 rl -1 1 rl 3 -1 rm sp } def
670 420 moveto
5 setlinewidth
/scale 7.96 def
r e f e r e n c e sp sp m a n u a l stroke
670 100 moveto
/scale 5 def
3 setlinewidth
n i l s sp sp m sp sp h o l m stroke
1010 100 moveto
d2 d0 d1 d9 sp d0 d7 sp d2 d6 stroke
621 0 moveto 621 810 lineto stroke

3621
lisp9.txt Normal file
View File

File diff suppressed because it is too large Load Diff

5665
ls9.c Normal file
View File

File diff suppressed because it is too large Load Diff

769
ls9.ls9 Normal file
View File

@ -0,0 +1,769 @@
;;; LISP9 Derived Syntax and Functions
;;; Nils M Holm, 2018,2019
;;; In the public domain
;;;
;;; If your country does not have a concept like the public
;;; domain, the Creative Common Zero (CC0) licence applies,
;;; see https://creativecommons.org/publicdomain/zero/1.0/
nil t
(defun (cons x y) (cons x y))
(defun (car x) (car x))
(defun (cdr x) (cdr x))
(defun (caar x) (caar x))
(defun (cadr x) (cadr x))
(defun (cdar x) (cdar x))
(defun (cddr x) (cddr x))
(defun (caaar x) (car (caar x)))
(defun (caadr x) (car (cadr x)))
(defun (cadar x) (car (cdar x)))
(defun (caddr x) (car (cddr x)))
(defun (cdaar x) (cdr (caar x)))
(defun (cdadr x) (cdr (cadr x)))
(defun (cddar x) (cdr (cdar x)))
(defun (cdddr x) (cdr (cddr x)))
(defun (list . x) x)
(defun (vector . x) (listvec x))
(defun (string . x) (liststr x))
(defun (rever a)
(reconc a nil))
(defun (nrever a)
(nreconc a nil))
(defmac (cond . cs)
(if (null cs)
nil
(if (eq 'else (caar cs))
(cons 'prog (cdar cs))
(list 'if (caar cs)
(cons 'prog (cdar cs))
(cons 'cond (cdr cs))))))
(defmac (and . xs)
(cond ((null xs) 't)
((null (cdr xs)) (car xs))
(else (list 'if (car xs)
(cons 'and (cdr xs))
nil))))
(defmac (qquote x)
(cond ((vectorp x)
(list 'listvec
(list 'qquote (veclist x))))
((not (pair x))
(list 'quote x))
((eq 'unquote (car x))
(cadr x))
((and (pair (car x))
(eq 'unquote (caar x)))
(list 'cons (cadar x)
(list 'qquote (cdr x))))
((and (pair (car x))
(eq 'splice (caar x)))
(list 'conc (cadar x)
(list 'qquote (cdr x))))
(else
(list 'cons (list 'qquote (car x))
(list 'qquote (cdr x))))))
(defmac (let bs x . xs)
((lambda (split)
(setq split
(lambda (bs vs as)
(if (null bs)
(list vs as)
(split (cdr bs)
(cons (caar bs) vs)
(cons (cadar bs) as)))))
(apply (lambda (vs as)
@((lambda ,vs ,x . ,xs) . ,as))
(split bs nil nil)))
nil))
(defun (mapcar f a . b)
(if (null b)
(let ((m1 nil))
(setq m1 (lambda (a)
(if (null a)
nil
(cons (f (car a))
(m1 (cdr a))))))
(m1 a))
(let ((m2 nil))
(setq m2 (lambda (a b)
(if (null a)
nil
(cons (f (car a) (car b))
(m2 (cdr a) (cdr b))))))
(m2 a (car b)))))
(defmac (labels bs x . xs)
(let ((vs (mapcar car bs))
(as (mapcar cadr bs)))
(let ((ns (mapcar (lambda (v) (list v nil)) vs))
(is (mapcar (lambda (v a) (list 'setq v a)) vs as)))
@(let ,ns ,@is ,x . ,xs))))
(defmac (or . xs)
(cond ((null xs) nil)
((null (cdr xs)) (car xs))
(else @(if* ,(car xs)
(or . ,(cdr xs))))))
(defmac (cond . cs)
(cond ((null cs) nil)
((null (cdar cs))
@(if* ,(caar cs)
(cond . ,(cdr cs))))
((eq '=> (cadar cs))
(let ((g (gensym)))
@(let ((,g ,(caar cs)))
(if ,g (,(caddr (car cs)) ,g)
(cond . ,(cdr cs))))))
((eq 'else (caar cs))
@(prog . ,(cdar cs)))
((null (cdr cs))
@(if ,(caar cs)
(prog . ,(cdar cs))))
(else
@(if ,(caar cs)
(prog . ,(cdar cs))
(cond . ,(cdr cs))))))
(defmac (case x . cs)
(defun (cases x cs)
(cond ((null cs) nil)
((eq 'else (caar cs))
@(prog . ,(cdar cs)))
(else
@(if (memv ,x ',(caar cs))
(prog . ,(cdar cs))
,(cases x (cdr cs))))))
(let ((g (gensym)))
@(let ((,g ,x))
,(cases g cs))))
(defmac (let* bs x . xs)
(if (null bs)
@(let () ,x . ,xs)
@(let (,(car bs))
(let* ,(cdr bs) ,x . ,xs))))
(defmac (let x0 x . xs)
(if (symbolp x0)
(let ((vs (mapcar car x))
(as (mapcar cadr x)))
@((labels ((,x0 (lambda ,vs . ,xs)))
,x0) . ,as))
(let ((vs (mapcar car x0))
(as (mapcar cadr x0)))
@((lambda ,vs ,x . ,xs) . ,as))))
(defmac (with bs x . xs)
(let* ((vs (mapcar car bs))
(gs (mapcar (lambda (x) (gensym)) bs))
(as (mapcar cadr bs))
(set (mapcar (lambda (v a) @(setq ,v ,a)) vs as))
(res (mapcar (lambda (v g) @(setq ,v ,g)) vs gs))
(val (gensym)))
@((lambda ,gs
(unwind
(lambda () (prog . ,res))
(lambda ()
,@set
,x . ,xs))) . ,vs)))
(defmac (do bs tst . xs)
(let ((fn (gensym))
(vs (mapcar car bs))
(as (mapcar cadr bs))
(ss (mapcar cddr bs)))
(let ((ss (mapcar (lambda (s v)
(if (null s) v (car s)))
ss vs)))
@(labels
((,fn (lambda ,vs
(if ,(car tst)
(prog . ,(cdr tst))
(prog ,@xs (,fn . ,ss))))))
(,fn . ,as)))))
(defun (fold f b a)
(defun (fl a r)
(if (null a)
r
(fl (cdr a)
(f r (car a)))))
(fl a b))
(defun (foldr f b a)
(defun (fr a r)
(if (null a)
r
(fr (cdr a)
(f (car a) r))))
(fr (rever a) b))
(defun (filter p a)
(defun (fi a r)
(cond ((null a) (nrever r))
((p (car a))
(fi (cdr a) (cons (car a) r)))
(else
(fi (cdr a) r))))
(fi a nil))
(defun (memq x a)
(cond ((null a) nil)
((eq x (car a)) a)
(else (memq x (cdr a)))))
(defun (mapcar f a . as)
(defun (map f x)
(if (null x)
nil
(cons (f (car x))
(map f (cdr x)))))
(defun (car* x) (map car x))
(defun (cdr* x) (map cdr x))
(defun (nil* x) (memq nil x))
(defun (mapcar* as r)
(if (nil* as)
(nrever r)
(mapcar* (cdr* as)
(cons (apply f (car* as))
r))))
(mapcar* (cons a as) nil))
(defun (foreach f a . as)
(apply mapcar f a as)
nil)
(defun (length ls)
(defun (len a n)
(cond ((null a) n)
((pair a) (len (cdr a) (+ 1 n)))
(else (error "length: improper list" ls))))
(len ls 0))
(defun (nth-tail n a)
(if (= 0 n)
a
(nth-tail (- n 1) (cdr a))))
(defun (nth n a) (car (nth-tail n a)))
(defun (listp x)
(defun (acyclicp x y)
(cond ((eq x y) nil)
((null x))
((pair x)
(or (null (cdr x))
(and (pair (cdr x))
(acyclicp (cddr x) (cdr y)))))
(else nil)))
(or (null x)
(and (pair x)
(acyclicp (cdr x) x))))
(defun (caaaar x) (caar (caar x)))
(defun (caaadr x) (caar (cadr x)))
(defun (caadar x) (caar (cdar x)))
(defun (caaddr x) (caar (cddr x)))
(defun (cadaar x) (cadr (caar x)))
(defun (cadadr x) (cadr (cadr x)))
(defun (caddar x) (cadr (cdar x)))
(defun (cadddr x) (cadr (cddr x)))
(defun (cdaaar x) (cdar (caar x)))
(defun (cdaadr x) (cdar (cadr x)))
(defun (cdadar x) (cdar (cdar x)))
(defun (cdaddr x) (cdar (cddr x)))
(defun (cddaar x) (cddr (caar x)))
(defun (cddadr x) (cddr (cadr x)))
(defun (cdddar x) (cddr (cdar x)))
(defun (cddddr x) (cddr (cddr x)))
(defun (eqv a b)
(cond ((eq a b))
((and (fixp a)
(fixp b)
(= a b)))
((and (charp a)
(charp b)
(c= a b)))
(else nil)))
(defun (equal a b)
(defun (equvec a b)
(and (= (vsize a) (vsize b))
(let loop ((i (- (vsize a) 1)))
(cond ((< i 0))
((equal (vref a i) (vref b i))
(loop (- i 1)))
(else nil)))))
(cond ((eq a b))
((and (pair a)
(pair b)
(equal (car a) (car b))
(equal (cdr a) (cdr b))))
((and (stringp a)
(stringp b)
(s= a b)))
((and (vectorp a)
(vectorp b)
(equvec a b)))
(else (eqv a b))))
(defun (memv x a)
(cond ((null a) nil)
((eqv x (car a)) a)
(else (memv x (cdr a)))))
(defun (member x a)
(cond ((null a) nil)
((equal x (car a)) a)
(else (member x (cdr a)))))
(defun (assq x a)
(cond ((null a) nil)
((eq x (caar a)) (car a))
(else (assq x (cdr a)))))
(defun (assv x a)
(cond ((null a) nil)
((eqv x (caar a)) (car a))
(else (assv x (cdr a)))))
(defun (assoc x a)
(cond ((null a) nil)
((equal x (caar a)) (car a))
(else (assoc x (cdr a)))))
(defmac (andb x y . z) @(bitop 1 ,x ,y . ,z))
(defmac (xorb x y . z) @(bitop 6 ,x ,y . ,z))
(defmac (orb x y . z) @(bitop 7 ,x ,y . ,z))
(defmac (norb x y . z) @(bitop 8 ,x ,y . ,z))
(defmac (eqvb x y . z) @(bitop 9 ,x ,y . ,z))
(defmac (notb x) @(bitop 12 ,x 0))
(defmac (nandb x y . z) @(bitop 14 ,x ,y . ,z))
(defmac (shlb x y . z) @(bitop 16 ,x ,y . ,z))
(defmac (shrb x y . z) @(bitop 17 ,x ,y . ,z))
(defmac (asrb x y . z) @(bitop 18 ,x ,y . ,z))
(defun (andb x y . z) (apply bitop 1 x y z))
(defun (xorb x y . z) (apply bitop 6 x y z))
(defun (orb x y . z) (apply bitop 7 x y z))
(defun (norb x y . z) (apply bitop 8 x y z))
(defun (eqvb x y . z) (apply bitop 9 x y z))
(defun (notb x) (bitop 12 x 0))
(defun (nandb x y . z) (apply bitop 14 x y z))
(defun (shlb x y . z) (apply bitop 16 x y z))
(defun (asrb x y . z) (apply bitop 17 x y z))
(defun (evenp x) (= 0 (rem x 2)))
(defun (oddp x) (not (evenp x)))
(defun (gcd x y)
(defun (gcd x y)
(cond ((= 0 x) y)
((= 0 y) x)
((< x y) (gcd x (rem y x)))
(else (gcd y (rem x y)))))
(gcd (abs x) (abs y)))
(defun (lcm x y)
(let ((cd (gcd x y)))
(abs (* cd (div x cd) (div y cd)))))
(defun (expt x y)
(defun (square x) (* x x))
(defun (expt2 x y)
(cond ((= 0 y) 1)
((evenp y) (square (expt2 x (div y 2))))
(else (* x (square (expt2 x (div y 2)))))))
(defun (nexpt y r)
(cond ((= 0 y) r)
(else (nexpt (- y 1) (* r x)))))
(if (> y 20)
(expt2 x y)
(nexpt y 1)))
(defun (mod x y)
(let ((r (rem x y)))
(cond ((= 0 r) 0)
((eq (< x 0) (< y 0)) r)
(else (+ y r)))))
(defun (scopy s)
(substr s 0 (ssize s)))
(defun (terpri . p)
(if (and (pair p)
(pair (cdr p)))
(error "terpri: too many arguments"))
(apply writec #\nl p))
(defun (print . xs)
(cond ((null xs) (princ "\n"))
((null (cdr xs))
(prin (car xs))
(princ "\n"))
(else
(prin (car xs))
(writec #\sp)
(apply print (cdr xs)))))
(defun (readln . p)
(let loop ((c (apply readc p))
(a nil))
(cond ((eofp c)
(if (null a)
c
(liststr (nrever a))))
((c= #\nl c)
(liststr (nrever a)))
(else
(loop (apply readc p)
(cons c a))))))
(defun (with-infile s f)
(let ((oi (inport))
(i (open-infile s)))
(unwind
(lambda ()
(set-inport oi)
(close-port i))
(lambda ()
(set-inport i)
(f)))))
(defun (with-outfile s f)
(let ((oo (outport))
(o (open-outfile s)))
(unwind
(lambda ()
(set-outport oo)
(close-port o))
(lambda ()
(set-outport o)
(f)))))
(defun (with-inport s f)
(let ((i (open-infile s)))
(unwind
(lambda ()
(close-port i))
(lambda ()
(f i)))))
(defun (with-outport s f)
(let ((o (open-outfile s)))
(unwind
(lambda ()
(close-port o))
(lambda ()
(f o)))))
(def *unwind* nil)
(defun (catch x)
(let ((r (catch*
(lambda (c)
(setq *unwind* (cons c *unwind*))
(x c)))))
(setq *unwind* (cdr *unwind*))
r))
(defun (throw c v)
(let loop ()
(cond ((null *unwind*)
(throw* c v))
((funp (car *unwind*))
(let ((w (car *unwind*)))
(setq *unwind* (cdr *unwind*))
(w)
(loop)))
((eq c (car *unwind*))
(throw* c v))
(else
(setq *unwind* (cdr *unwind*))
(loop)))))
(defun (unwind u f)
(setq *unwind* (cons u *unwind*))
(let ((v (f)) (w nil))
(setq w (car *unwind*))
(setq *unwind* (cdr *unwind*))
(w)
v))
(defmac (catch-errors v x . xs)
(let ((g (gensym))
(r (gensym))
(et (gensym))
(ev (gensym)))
@(let ((,et *Errtag*)
(,ev *Errval*))
(let ((,r (catch*
(lambda (,g)
(setq *Errval*
,(if (null v) g (car v)))
(setq *Errtag* ,g)
,x . ,xs))))
(setq *Errtag* ,et)
(setq *Errval* ,ev)
,r))))
(defun (save)
(if *imagefile*
(dump-image *imagefile*)
(error "save: no image loaded, use \"dump-image\"")))
(defun (cmdline) (cmdline))
(defun (errport) (errport))
(defun (inport) (inport))
(defun (outport) (outport))
(defun (gc) (gc))
(defun (gensym) (gensym))
(defun (obtab) (obtab))
(defun (quit) (quit))
(defun (symtab) (symtab))
(defun (abs x) (abs x))
(defun (alphac x) (alphac x))
(defun (atom x) (atom x))
(defun (catch* x) (catch* x))
(defun (char x) (char x))
(defun (charp x) (charp x))
(defun (charval x) (charval x))
(defun (close-port x) (close-port x))
(defun (ctagp x) (ctagp x))
(defun (constp x) (constp x))
(defun (delete x) (delete x))
(defun (downcase x) (downcase x))
(defun (dump-image x) (dump-image x))
(defun (eofp x) (eofp x))
(defun (existsp x) (existsp x))
(defun (fixp x) (fixp x))
(defun (flush x) (flush x))
(defun (format x) (format x))
(defun (funp x) (funp x))
(defun (inportp x) (inportp x))
(defun (liststr x) (liststr x))
(defun (listvec x) (listvec x))
(defun (load x) (load x))
(defun (lowerc x) (lowerc x))
(defun (mx x) (mx x))
(defun (mx1 x) (mx1 x))
(defun (not x) (not x))
(defun (null x) (null x))
(defun (numeric x) (numeric x))
(defun (open-infile x) (open-infile x))
(defun (outportp x) (outportp x))
(defun (pair x) (pair x))
(defun (set-inport x) (set-inport x))
(defun (set-outport x) (set-outport x))
(defun (ssize x) (ssize x))
(defun (stringp x) (stringp x))
(defun (strlist x) (strlist x))
(defun (symbol x) (symbol x))
(defun (symbolp x) (symbolp x))
(defun (symname x) (symname x))
(defun (syscmd x) (syscmd x))
(defun (untag x) (untag x))
(defun (upcase x) (upcase x))
(defun (upperc x) (upperc x))
(defun (veclist x) (veclist x))
(defun (vectorp x) (vectorp x))
(defun (vsize x) (vsize x))
(defun (whitec x) (whitec x))
(defun (div x y) (div x y))
(defun (eq x y) (eq x y))
(defun (nreconc x y) (nreconc x y))
(defun (rem x y) (rem x y))
(defun (reconc x y) (reconc x y))
(defun (reanme x y) (rename x y))
(defun (setcar x y) (setcar x y))
(defun (setcdr x y) (setcdr x y))
(defun (sfill x y) (sfill x y))
(defun (sref x y) (sref x y))
(defun (throw* x y) (throw* x y))
(defun (vfill x y) (vfill x y))
(defun (vref x y) (vref x y))
(defun (+ . x) (fold (lambda (x y) (+ x y)) 0 x))
(defun (* . x) (fold (lambda (x y) (* x y)) 1 x))
(defun (conc . x) (fold (lambda (x y) (conc x y)) nil x))
(defun (nconc . x) (fold (lambda (x y) (nconc x y)) nil x))
(defun (sconc . x) (fold (lambda (x y) (sconc x y)) "" x))
(defun (vconc . x) (fold (lambda (x y) (vconc x y)) #() x))
(defun (peekc . x)
(cond ((null x)
(peekc))
((null (cdr x))
(peekc (car x)))
(else
(error "peekc: too many arguments"))))
(defun (read . x)
(cond ((null x)
(read))
((null (cdr x))
(read (car x)))
(else
(error "read: too many arguments"))))
(defun (readc . x)
(cond ((null x)
(readc))
((null (cdr x))
(readc (car x)))
(else
(error "readc: too many arguments"))))
(defun (bitop op x y . z)
(fold (lambda (x y) (bitop op x y))
x
(cons y z)))
(defun (- x . y)
(if (null y)
(- x)
(fold (lambda (x y) (- x y)) x y)))
(defun (max x . y)
(if (null y)
x
(fold (lambda (x y) (max x y)) x y)))
(defun (min x . y)
(if (null y)
x
(fold (lambda (x y) (min x y)) x y)))
(defun (error x . y)
(cond ((null y)
(error x))
((null (cdr y))
(error x (car y)))
(else
(error "error: too many arguments"))))
(defun (mkstr x . y)
(cond ((null y)
(mkstr x))
((null (cdr y))
(mkstr x (car y)))
(else
(error "mkstr: too many arguments"))))
(defun (mkvec x . y)
(cond ((null y)
(mkvec x))
((null (cdr y))
(mkvec x (car y)))
(else
(error "mkstr: too many arguments"))))
(defun (numstr x . y)
(cond ((null y)
(numstr x))
((null (cdr y))
(numstr x (car y)))
(else
(error "numstr: too many arguments"))))
(defun (strnum x . y)
(cond ((null y)
(strnum x))
((null (cdr y))
(strnum x (car y)))
(else
(error "strnum: too many arguments"))))
(defun (open-outfile x . y)
(cond ((null y)
(open-outfile x))
((null (cdr y))
(open-outfile x (car y)))
(else
(error "open-outfile: too many arguments"))))
(defun (prin x . y)
(cond ((null y)
(prin x))
((null (cdr y))
(prin x (car y)))
(else
(error "prin: too many arguments"))))
(defun (princ x . y)
(cond ((null y)
(princ x))
((null (cdr y))
(princ x (car y)))
(else
(error "princ: too many arguments"))))
(defun (writec x . y)
(cond ((null y)
(writec x))
((null (cdr y))
(writec x (car y)))
(else
(error "writec: too many arguments"))))
(defun (%compare op a)
(let loop ((a a))
(cond ((null (cdr a)))
((op (car a) (cadr a))
(loop (cdr a)))
(else nil))))
(defun (< x . y) (%compare (lambda (x y) (< x y)) (cons x y)))
(defun (<= x . y) (%compare (lambda (x y) (<= x y)) (cons x y)))
(defun (= x . y) (%compare (lambda (x y) (= x y)) (cons x y)))
(defun (> x . y) (%compare (lambda (x y) (> x y)) (cons x y)))
(defun (>= x . y) (%compare (lambda (x y) (>= x y)) (cons x y)))
(defun (c< x . y) (%compare (lambda (x y) (c< x y)) (cons x y)))
(defun (c<= x . y) (%compare (lambda (x y) (c<= x y)) (cons x y)))
(defun (c= x . y) (%compare (lambda (x y) (c= x y)) (cons x y)))
(defun (c> x . y) (%compare (lambda (x y) (c> x y)) (cons x y)))
(defun (c>= x . y) (%compare (lambda (x y) (c>= x y)) (cons x y)))
(defun (s< x . y) (%compare (lambda (x y) (s< x y)) (cons x y)))
(defun (s<= x . y) (%compare (lambda (x y) (s<= x y)) (cons x y)))
(defun (s= x . y) (%compare (lambda (x y) (s= x y)) (cons x y)))
(defun (s> x . y) (%compare (lambda (x y) (s> x y)) (cons x y)))
(defun (s>= x . y) (%compare (lambda (x y) (s>= x y)) (cons x y)))
(defun (si< x . y) (%compare (lambda (x y) (si< x y)) (cons x y)))
(defun (si<= x . y) (%compare (lambda (x y) (si<= x y)) (cons x y)))
(defun (si= x . y) (%compare (lambda (x y) (si= x y)) (cons x y)))
(defun (si> x . y) (%compare (lambda (x y) (si> x y)) (cons x y)))
(defun (si>= x . y) (%compare (lambda (x y) (si>= x y)) (cons x y)))
(defun (sset x y z) (sset x y z))
(defun (substr x y z) (substr x y z))
(defun (subvec x y z) (subvec x y z))
(defun (vset x y z) (vset x y z))
(defun (apply f . as)
(let loop ((as as)
(a nil))
(cond ((null as)
(error "apply: too few arguments"))
((null (cdr as))
(if (pair (car as))
(apply f (conc (nrever a) (car as)))
(error "apply: expected list" (car as))))
(else
(loop (cdr as)
(cons (car as) a))))))

26
src/array.ls9 Normal file
View File

@ -0,0 +1,26 @@
;;; ARRAY1 -- One of the Kernighan and Van Wyk benchmarks.
(defun (create-x n)
(def result (mkvec n))
(do ((i 0 (+ i 1)))
((>= i n) result)
(vset result i i)))
(defun (create-y x)
(let* ((n (vsize x))
(result (mkvec n)))
(do ((i (- n 1) (- i 1)))
((< i 0) result)
(vset result i (vref x i)))))
(defun (my-try n)
(vsize (create-y (create-x n))))
(defun (go n)
(let loop ((repeat 10000)
(result '()))
(if (> repeat 0)
(loop (- repeat 1) (my-try n))
result)))
(print (go 100))

543
src/boyer.ls9 Normal file
View File

@ -0,0 +1,543 @@
;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
;;; From the Gabriel benchmark suite
(defun (lookup key table)
(let loop ((x table))
(if (null x)
nil
(let ((pair (car x)))
(if (eq (car pair) key)
pair
(loop (cdr x)))))))
(def properties '())
(defun (get key1 key2)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(cdr y)
nil))
nil)))
(defun (put key1 key2 val)
(let ((x (lookup key1 properties)))
(if x
(let ((y (lookup key2 (cdr x))))
(if y
(setcdr y val)
(setcdr x (cons (cons key2 val) (cdr x)))))
(setq properties
(cons (list key1 (cons key2 val)) properties)))))
(def unify-subst '())
(defun (add-lemma term)
(cond ((and (pair term)
(eq (car term)
(quote equal))
(pair (cadr term)))
(put (car (cadr term))
(quote lemmas)
(cons term (get (car (cadr term)) (quote lemmas)))))
(else (fatal-error "ADD-LEMMA did not like term: " term))))
(defun (add-lemma-lst lst)
(cond ((null lst)
t)
(else (add-lemma (car lst))
(add-lemma-lst (cdr lst)))))
(defun (apply-subst alist term)
(cond ((not (pair term))
(cond ((assq term alist) => cdr)
(else term)))
(else (cons (car term)
(apply-subst-lst alist (cdr term))))))
(defun (apply-subst-lst alist lst)
(cond ((null lst)
'())
(else (cons (apply-subst alist (car lst))
(apply-subst-lst alist (cdr lst))))))
(defun (falsep x lst)
(or (equal x (quote (f)))
(member x lst)))
(defun (one-way-unify term1 term2)
(prog (setq unify-subst '())
(one-way-unify1 term1 term2)))
(defun (one-way-unify1 term1 term2)
(cond ((not (pair term2))
(cond ((assq term2 unify-subst) =>
(lambda (x) (equal term1 (cdr x))))
(else (setq unify-subst (cons (cons term2 term1)
unify-subst))
t)))
((not (pair term1))
nil)
((eq (car term1)
(car term2))
(one-way-unify1-lst (cdr term1)
(cdr term2)))
(else nil)))
(defun (one-way-unify1-lst lst1 lst2)
(cond ((null lst1)
t)
((one-way-unify1 (car lst1)
(car lst2))
(one-way-unify1-lst (cdr lst1)
(cdr lst2)))
(else nil)))
(defun (rewrite term)
(cond ((not (pair term))
term)
(else (rewrite-with-lemmas
(cons (car term)
(rewrite-args (cdr term)))
(get (car term)
(quote lemmas))))))
(defun (rewrite-args lst)
(cond ((null lst)
'())
(else (cons (rewrite (car lst))
(rewrite-args (cdr lst))))))
(defun (rewrite-with-lemmas term lst)
(cond ((or (not lst) (null lst))
term)
((one-way-unify term (cadr (car lst)))
(rewrite (apply-subst unify-subst (caddr (car lst)))))
(else (rewrite-with-lemmas term (cdr lst)))))
(defun (setup)
(add-lemma-lst
(quote ((equal (compile form)
(reverse (codegen (optimize form)
(nil))))
(equal (eqp x y)
(equal (fix x)
(fix y)))
(equal (greaterp x y)
(lessp y x))
(equal (lesseqp x y)
(not (lessp y x)))
(equal (greatereqp x y)
(not (lessp x y)))
(equal (boolean x)
(or (equal x (t))
(equal x (f))))
(equal (iff x y)
(and (implies x y)
(implies y x)))
(equal (even1 x)
(if (zerop x)
(t)
(odd (_1- x))))
(equal (countps- l pred)
(countps-loop l pred (zero)))
(equal (fact- i)
(fact-loop i 1))
(equal (reverse- x)
(reverse-loop x (nil)))
(equal (divides x y)
(zerop (remainder y x)))
(equal (assume-true var alist)
(cons (cons var (t))
alist))
(equal (assume-false var alist)
(cons (cons var (f))
alist))
(equal (tautology-checker x)
(tautologyp (normalize x)
(nil)))
(equal (falsify x)
(falsify1 (normalize x)
(nil)))
(equal (prime x)
(and (not (zerop x))
(not (equal x (add1 (zero))))
(prime1 x (_1- x))))
(equal (and p q)
(if p (if q (t)
(f))
(f)))
(equal (or p q)
(if p (t)
(if q (t)
(f))
(f)))
(equal (not p)
(if p (f)
(t)))
(equal (implies p q)
(if p (if q (t)
(f))
(t)))
(equal (fix x)
(if (numberp x)
x
(zero)))
(equal (if (if a b c)
d e)
(if a (if b d e)
(if c d e)))
(equal (zerop x)
(or (equal x (zero))
(not (numberp x))))
(equal (plus (plus x y) z)
(plus x (plus y z)))
(equal (equal (plus a b)
(zero))
(and (zerop a)
(zerop b)))
(equal (difference x x)
(zero))
(equal (equal (plus a b)
(plus a c))
(equal (fix b)
(fix c)))
(equal (equal (zero)
(difference x y))
(not (lessp y x)))
(equal (equal x (difference x y))
(and (numberp x)
(or (equal x (zero))
(zerop y))))
(equal (meaning (plus-tree (conc x y))
a)
(plus (meaning (plus-tree x)
a)
(meaning (plus-tree y)
a)))
(equal (meaning (plus-tree (plus-fringe x))
a)
(fix (meaning x a)))
(equal (conc (conc x y) z)
(conc x (conc y z)))
(equal (reverse (conc a b))
(conc (reverse b)
(reverse a)))
(equal (times x (plus y z))
(plus (times x y)
(times x z)))
(equal (times (times x y) z)
(times x (times y z)))
(equal (equal (times x y)
(zero))
(or (zerop x)
(zerop y)))
(equal (exec (conc x y)
pds envrn)
(exec y (exec x pds envrn)
envrn))
(equal (mc-flatten x y)
(conc (flatten x) y))
(equal (member x (conc a b))
(or (member x a)
(member x b)))
(equal (member x (reverse y))
(member x y))
(equal (length (reverse x))
(length x))
(equal (member a (intersect b c))
(and (member a b)
(member a c)))
(equal (nth (zero) i)
(zero))
(equal (exp i (plus j k))
(times (exp i j)
(exp i k)))
(equal (exp i (times j k))
(exp (exp i j) k))
(equal (reverse-loop x y)
(conc (reverse x) y))
(equal (reverse-loop x (nil))
(reverse x))
(equal (count-list z (sort-lp x y))
(plus (count-list z x)
(count-list z y)))
(equal (equal (conc a b)
(conc a c))
(equal b c))
(equal (plus (remainder x y)
(times y (quotient x y)))
(fix x))
(equal (power-eval (big-plus1 l i base)
base)
(plus (power-eval l base) i))
(equal (power-eval (big-plus x y i base)
base)
(plus i (plus (power-eval x base)
(power-eval y base))))
(equal (remainder y 1)
(zero))
(equal (lessp (remainder x y) y)
(not (zerop y)))
(equal (remainder x x)
(zero))
(equal (lessp (quotient i j) i)
(and (not (zerop i))
(or (zerop j)
(not (equal j 1)))))
(equal (lessp (remainder x y) x)
(and (not (zerop y))
(not (zerop x))
(not (lessp x y))))
(equal (power-eval (power-rep i base)
base)
(fix i))
(equal (power-eval (big-plus (power-rep i base)
(power-rep j base)
(zero)
base)
base)
(plus i j))
(equal (gcd x y)
(gcd y x))
(equal (nth (conc a b) i)
(conc (nth a i)
(nth b (difference i (length a)))))
(equal (difference (plus x y)
x)
(fix y))
(equal (difference (plus y x) x)
(fix y))
(equal (difference (plus x y)
(plus x z))
(difference y z))
(equal (times x (difference c w))
(difference (times c x)
(times w x)))
(equal (remainder (times x z)
z)
(zero))
(equal (difference (plus b (plus a c))
a)
(plus b c))
(equal (difference (add1 (plus y z))
z)
(add1 y))
(equal (lessp (plus x y)
(plus x z))
(lessp y z))
(equal (lessp (times x z)
(times y z))
(and (not (zerop z))
(lessp x y)))
(equal (lessp y (plus x y))
(not (zerop x)))
(equal (gcd (times x z)
(times y z))
(times z (gcd x y)))
(equal (value (normalize x)
a)
(value x a))
(equal (equal (flatten x)
(cons y (nil)))
(and (nlistp x)
(equal x y)))
(equal (listp (gopher x))
(listp x))
(equal (samefringe x y)
(equal (flatten x)
(flatten y)))
(equal (equal (greatest-factor x y)
(zero))
(and (or (zerop y)
(equal y 1))
(equal x (zero))))
(equal (equal (greatest-factor x y) 1)
(equal x 1))
(equal (numberp (greatest-factor x y))
(not (and (or (zerop y)
(equal y 1))
(not (numberp x)))))
(equal (times-list (conc x y))
(times (times-list x)
(times-list y)))
(equal (prime-list (conc x y))
(and (prime-list x)
(prime-list y)))
(equal (equal z (times w z))
(and (numberp z)
(or (equal z (zero))
(equal w 1))))
(equal (greatereqpr x y)
(not (lessp x y)))
(equal (equal x (times x y))
(or (equal x (zero))
(and (numberp x)
(equal y 1))))
(equal (remainder (times y x) y)
(zero))
(equal (equal (times a b) 1)
(and (not (equal a (zero)))
(not (equal b (zero)))
(numberp a)
(numberp b)
(equal (_1- a)
(zero))
(equal (_1- b)
(zero))))
(equal (lessp (length (delete x l))
(length l))
(member x l))
(equal (sort2 (delete x l))
(delete x (sort2 l)))
(equal (dsort x)
(sort2 x))
(equal (length (cons x1
(cons x2
(cons x3 (cons x4
(cons x5
(cons x6 x7)))))))
(plus 6 (length x7)))
(equal (difference (add1 (add1 x))
2)
(fix x))
(equal (quotient (plus x (plus x y))
2)
(plus x (quotient y 2)))
(equal (sigma (zero) i)
(quotient (times i (add1 i))
2))
(equal (plus x (add1 y))
(if (numberp y)
(add1 (plus x y))
(add1 x)))
(equal (equal (difference x y)
(difference z y))
(if (lessp x y)
(not (lessp y z))
(if (lessp z y)
(not (lessp y x))
(equal (fix x)
(fix z)))))
(equal (meaning (plus-tree (delete x y))
a)
(if (member x y)
(difference (meaning (plus-tree y)
a)
(meaning x a))
(meaning (plus-tree y)
a)))
(equal (times x (add1 y))
(if (numberp y)
(plus x (times x y))
(fix x)))
(equal (nth (nil) i)
(if (zerop i)
(nil)
(zero)))
(equal (last (conc a b))
(if (listp b)
(last b)
(if (listp a)
(cons (car (last a)) b)
b)))
(equal (equal (lessp x y) z)
(if (lessp x y)
(equal t z)
(equal f z)))
(equal (assignment x (conc a b))
(if (assignedp x a)
(assignment x a)
(assignment x b)))
(equal (car (gopher x))
(if (listp x)
(car (flatten x))
(zero)))
(equal (flatten (cdr (gopher x)))
(if (listp x)
(cdr (flatten x))
(cons (zero)
(nil))))
(equal (quotient (times y x)
y)
(if (zerop y)
(zero)
(fix x)))
(equal (get j (set i val mem))
(if (eqp j i)
val
(get j mem)))))))
(defun (tautologyp x true-lst false-lst)
(cond ((truep x true-lst)
t)
((falsep x false-lst)
nil)
((not (pair x))
nil)
((eq (car x)
(quote if))
(cond ((truep (cadr x)
true-lst)
(tautologyp (caddr x)
true-lst false-lst))
((falsep (cadr x)
false-lst)
(tautologyp (cadddr x)
true-lst false-lst))
(else (and (tautologyp (caddr x)
(cons (cadr x)
true-lst)
false-lst)
(tautologyp (cadddr x)
true-lst
(cons (cadr x)
false-lst))))))
(else nil)))
(defun (tautp x)
(tautologyp (rewrite x)
'() '()))
(defun (test alist term)
(tautp (apply-subst alist term)))
(defun (trans-of-implies n)
(list (quote implies)
(trans-of-implies1 n)
(list (quote implies)
0 n)))
(defun (trans-of-implies1 n)
(cond ((equal n 1)
(list (quote implies)
0 1))
(else (list (quote and)
(list (quote implies)
(- n 1)
n)
(trans-of-implies1 (- n 1))))))
(defun (truep x lst)
(or (equal x (quote (t)))
(member x lst)))
(setup)
(test
(quote ((x f (plus (plus a b)
(plus c (zero))))
(y f (times (times a b)
(plus c d)))
(z f (reverse (conc (conc a b)
(nil))))
(u equal (plus a b)
(difference x y))
(w lessp (remainder a b)
(member a (length b)))))
(quote (implies (and (implies x y)
(and (implies y z)
(and (implies z u)
(implies u w))))
(implies x w))))

14
src/ctak.ls9 Normal file
View File

@ -0,0 +1,14 @@
(defun (ctak x y z)
(defun (ctak-aux k x y z)
(if (not (< y x))
(throw* k z)
(catch*
(lambda (k)
(ctak-aux
k
(catch* (lambda (k) (ctak-aux k (- x 1) y z)))
(catch* (lambda (k) (ctak-aux k (- y 1) z x)))
(catch* (lambda (k) (ctak-aux k (- z 1) x y))))))))
(catch (lambda (k) (ctak-aux k x y z))))
(ctak 18 12 6)

139
src/disasm.ls9 Normal file
View File

@ -0,0 +1,139 @@
;;; LISP9 DISASM
;;; Nils M Holm, 2018
;;; In the public domain
(defun (iota n)
(defun (i n a)
(if (< n 0)
a
(i (- n 1) (cons n a))))
(i (- n 1) nil))
(defmac (enum syms . body)
(let* ((k (length syms))
(ns (iota k)))
@((lambda ,syms . ,body) . ,ns)))
(defun (disasm* p)
(enum (op:ill op:applis op:applist op:apply op:tailapp op:quote op:arg
op:ref op:push op:pushtrue op:pushval op:pop op:drop op:jmp
op:brf op:brt op:halt op:catchstar op:throwstar op:closure
op:mkenv op:propenv op:cpref op:cparg op:enter op:entcol
op:return op:setarg op:setref op:macro op:abs op:alphac op:atom
op:bitop op:caar op:cadr op:car op:cdar op:cddr op:cdr
op:cequal op:cgrtr op:cgteq op:char op:charp op:charval
op:cless op:close_port op:clteq op:cmdline op:conc op:cons
op:constp op:ctagp op:delete op:div op:downcase op:dump_image
op:eofp op:eq op:equal op:error op:error2 op:errport op:eval
op:existsp op:fixp op:flush op:format op:funp op:gc op:gensym
op:grtr op:gteq op:inport op:inportp op:less op:liststr
op:listvec op:load op:lowerc op:lteq op:max op:min op:minus
op:mkstr op:mkvec op:mx op:mx1 op:nconc op:negate op:nreconc
op:null op:numeric op:numstr op:obtab op:open_infile
op:open_outfile op:outport op:outportp op:pair op:peekc op:plus
op:prin op:princ op:quit op:read op:readc op:reconc op:rem
op:rename op:sconc op:sequal op:setcar op:setcdr op:set_inport
op:set_outport op:sfill op:sgrtr op:sgteq op:siequal op:sigrtr
op:sigteq op:siless op:silteq op:sless op:slteq op:sref op:sset
op:ssize op:stringp op:strlist op:strnum op:substr op:subvec
op:symbol op:symbolp op:symname op:symtab op:syscmd op:times
op:untag op:upcase op:upperc op:vconc op:veclist op:vectorp
op:vfill op:vref op:vset op:vsize op:whitec op:writec)
(let ((mnemonics
(listvec
'(ill applis applist apply tailapp quote arg ref push
pushtrue pushval pop drop jmp brf brt halt catch* throw*
closure mkenv propenv cpref cparg enter entcol return
setarg setref macro abs alphac atom bitop caar cadr car
cdar cddr cdr c= c> c>= char charp charval c< close-port
c<= cmdline conc cons constp ctagp delete div downcase
dump-image eofp eq = error error2 errport eval existsp
fixp flush format funp gc gensym > >= inport inportp <
liststr listvec load lowerc <= max min - mkstr mkvec mx
mx1 nconc negate nreconc null numeric numstr obtab
open-infile open-outfile outport outportp pair peekc +
prin princ quit read readc reconc rem rename sconc s=
setcar setcdr set-inport set-outport sfill s> s>= si= si>
si>= si< si<= s< s<= sref sset ssize stringp strlist
strnum substr subvec symbol symbolp symname symtab syscmd
* untag upcase upperc vconc veclist vectorp vfill vref
vset vsize whitec writec)))
(g2 (list op:quote op:arg op:pushval op:jmp op:brf op:brt
op:closure op:mkenv op:enter op:entcol op:setarg
op:setref op:macro))
(g3 (list op:ref op:cparg op:cpref)))
(let ((mnemo (lambda (op)
(vref mnemonics op)))
(arg (lambda (h l)
(orb (shlb h 8) l))))
(let loop ((bc (mapcar charval (strlist (untag p))))
(dis '()))
(cond ((null bc)
(nrever dis))
((= (car bc) op:quote)
(let ((a (arg (cadr bc) (caddr bc))))
(loop (cdddr bc)
(cons (list (mnemo (car bc))
(vref (obtab) a))
dis))))
((= (car bc) op:ref)
(let ((a (arg (cadddr bc) (car (cddddr bc)))))
(loop (cdddr (cddr bc))
(cons (list (mnemo (car bc))
(arg (cadr bc) (caddr bc))
(vref (symtab) a))
dis))))
((memv (car bc) g3)
(loop (cdddr (cddr bc))
(cons (list (mnemo (car bc))
(arg (cadr bc) (caddr bc))
(arg (cadddr bc) (car (cddddr bc))))
dis)))
((memv (car bc) g2)
(loop (cdddr bc)
(cons (list (mnemo (car bc))
(arg (cadr bc) (caddr bc)))
dis)))
(else
(loop (cdr bc)
(cons (list (mnemo (car bc)))
dis)))))))))
(defun (disasm p)
(def opsize 2)
(defun (numlen x)
(ssize (numstr x)))
(defun (symlen x)
(ssize (symname x)))
(defun (spaces n)
(cond ((> n 0)
(writec #\sp)
(spaces (- n 1)))))
(let* ((d (disasm* p))
(k (+ 1 (fold max 0 (mapcar symlen (mapcar car d)))))
(a 0))
(foreach
(lambda (x)
(spaces (- 5 (numlen a)))
(princ a)
(princ #\sp)
(princ (car x))
(cond ((pair (cdr x))
(spaces (- k (symlen (car x))))
(prin (cadr x))
(cond ((pair (cddr x))
(princ #\sp)
(prin (caddr x))))))
(terpri)
(setq a (+ a 1 (* opsize (- (length x) 1)))))
d)))

387
src/grind.ls9 Normal file
View File

@ -0,0 +1,387 @@
;;; LISP9 GRIND
;;; Nils M Holm, 2018
;;; In the public domain
(def *grind-inline* nil)
(def *grind-margin* 72)
(defun (grind x)
(def offset 0)
(def column 0)
(def doprint t)
(def maxcol 0)
(def LP "(")
(def RP ")")
(def SP " ")
(defun (prc c)
(writec c))
(defun (probj x)
(princ x))
(defun (osize x)
(ssize (format x)))
(defun (bleedp x)
(>= (+ column (osize x)) *grind-margin*))
(defun (spaces n)
(and doprint
(or (= 0 n)
(prog (prc #\sp)
(spaces (- n 1))))))
(defun (linefeed)
(if doprint
(prc #\nl))
(spaces offset)
(setq column offset))
(defun (pr s)
(if doprint
(probj s))
(setq column (+ column (ssize s)))
(if (> column maxcol)
(setq maxcol column)))
(defun (simplep a)
(= (length a)
(length (filter atom a))))
(defun (indentp x)
(and (memq x '(catch
with-infile
with-outfile
with-inport
with-outport))
t))
(defun (willfit fmt x)
(with ((column column)
(offset offset)
(maxcol 0)
(doprint nil))
(fmt x)
(< maxcol *grind-margin*)))
(defun (pp-pair x)
(pr LP)
(with ((offset (+ 1 offset)))
(let loop ((x x)
(s nil))
(cond ((pair x)
(if s
(if (or (pair (car x))
(vectorp (car x)))
(linefeed)
(if (willfit pp-obj (car x))
(pr SP)
(linefeed))))
(pp-obj (car x))
(loop (cdr x) t))
((not (null x))
(pr " . ")
(pp-obj x)))))
(pr RP))
(defun (pp-obj x)
(cond ((or (eq t x)
(eq nil x)
(null x)
(symbolp x)
(charp x)
(fixp x)
(stringp x))
(pr (format x)))
((vectorp x)
(if doprint
(prc #\#))
(with ((offset (+ 1 offset)))
(pp-pair (veclist x))))
((pair x)
(pp-pair x))
((funp x)
(pr "#<function>"))
(else
(error "grind: unknown type" x))))
(defun (pp-body x)
(cond ((not (null x))
(pp-form (car x))
(if (not (null (cdr x)))
(linefeed))
(pp-body (cdr x)))))
(defun (pp-inline x)
(pr (format x)))
(defun (pp-indent x)
(pr LP)
(pr (symname (car x)))
(if (not (null (cdr x)))
(pr SP))
(with ((offset (+ 2 (osize (car x)) offset)))
(let loop ((x (cdr x)))
(cond ((not (null x))
(pp-form (car x))
(if (not (null (cdr x)))
(linefeed))
(loop (cdr x)))))
(pr RP)))
(defun (pp-indent-2 x)
(pr LP)
(with ((offset (+ 1 offset)))
(pp-form (car x)))
(let ((indent (if (pair (car x)) 1 2)))
(with ((offset (+ indent offset)))
(if (not (null (cdr x)))
(linefeed))
(pp-body (cdr x)))
(pr RP)))
(defun (pp-app x)
(let ((inl (willfit pp-inline x)))
(cond ((and inl (simplep x))
(pp-inline x))
((indentp (car x))
(pp-indent-2 x))
(inl
(pp-inline x))
((willfit pp-indent x)
(pp-indent x))
(else
(pp-indent-2 x)))))
(defun (pp-quote x)
(pr "'")
(with ((offset (+ 1 offset)))
(pp-obj (cadr x))))
(defun (pp-qquote x)
(let ((sym (case (car x)
((qquote) "@")
((unquote) ",")
((splice) ",@"))))
(pr sym)
(with ((offset (+ offset (ssize sym))))
(pp-form (cadr x)))))
(defun (pp-lambda x)
(cond ((or (not *grind-inline*)
(> (length x) 3)
(bleedp x))
(pr LP)
(pr "lambda ")
(with ((offset (+ 2 offset)))
(pp-obj (cadr x))
(linefeed)
(pp-body (cddr x))
(pr RP)))
(else
(pp-inline x))))
(defun (pp-lamapp x)
(cond ((or (not *grind-inline*)
(bleedp x))
(pr LP)
(with ((offset (+ 1 offset)))
(pp-lambda (car x)))
(if (not (null (cdr x)))
(linefeed))
(with ((offset (+ 1 offset)))
(pr SP)
(pp-body (cdr x)))
(pr RP))
(else
(pp-inline x))))
(defun (pp-down x)
(let ((inl (willfit pp-inline x)))
(cond ((and inl (simplep x))
(pp-inline x))
((willfit pp-indent x)
(pp-indent x))
(else
(pp-indent-2 x)))))
(defun (pp-bs bs rec)
(pr LP)
(with ((offset (+ 1 offset)))
(let loop ((bs bs))
(cond ((not (null bs))
(pr LP)
(pp-inline (caar bs))
(cond ((and rec
(pair (cadar bs))
(> (osize (caar bs)) 2))
(with ((offset (+ 2 offset)))
(linefeed)
(pp-form (cadar bs))))
(else
(pr SP)
(with ((offset (+ 2 (osize (caar bs))
offset)))
(pp-form (cadar bs)))))
(pr RP)
(if (not (null (cdr bs)))
(linefeed))
(loop (cdr bs))))))
(pr RP))
(defun (pp-bind x)
(let ((k (osize (car x))))
(pr LP)
(pr (symname (car x)))
(pr SP)
(let* ((namedp (symbolp (cadr x)))
(bs (if namedp (caddr x) (cadr x)))
(xs (if namedp (cdddr x) (cddr x)))
(k (if namedp
(+ 3 k (osize (cadr x)))
(+ 2 k))))
(with ((offset (+ k offset)))
(cond (namedp
(pp-inline (cadr x))
(pr SP)))
(pp-bs bs (eq (car x) 'labels)))
(with ((offset (+ 2 offset)))
(linefeed)
(pp-body xs))
(pr RP))))
(defun (pp-do x)
(let ((init-part cadr)
(test-part caddr)
(body cdddr))
(pr LP)
(pr "do ")
(pr LP)
(with ((offset (+ 5 offset)))
(let loop ((ini (init-part x)))
(cond ((null ini))
(else
(pp-app (car ini))
(if (not (null (cdr ini)))
(linefeed))
(loop (cdr ini))))))
(pr RP)
(with ((offset (+ 4 offset)))
(linefeed)
(pr LP)
(pp-form (car (test-part x)))
(if (not (null (cdr (test-part x))))
(with ((offset (+ 2 offset)))
(linefeed)
(pp-body (cdr (test-part x)))))
(pr RP))
(if (not (null (body x)))
(with ((offset (+ 2 offset)))
(linefeed)
(pp-body (body x))))
(pr RP)))
(defun (pp-cond x)
(labels
((pr-cs
(lambda (cs)
(cond ((null cs))
((null (cdar cs))
(pp-form (car cs))
(if (not (null (cdr cs)))
(linefeed))
(pr-cs (cdr cs)))
((eq '=> (cadar cs))
(pr LP)
(pp-form (caar cs))
(linefeed)
(pr " => ")
(with ((offset column))
(pp-body (cddar cs))
(pr RP))
(if (not (null (cdr cs)))
(linefeed))
(pr-cs (cdr cs)))
(else
(pr LP)
(with ((offset (+ 1 offset)))
(if (eq (car x) 'cond)
(pp-form (caar cs))
(pp-obj (caar cs))))
(with ((offset (+ 2 offset)))
(linefeed)
(pp-body (cdar cs))
(pr RP))
(if (not (null (cdr cs)))
(linefeed))
(pr-cs (cdr cs)))))))
(pr LP)
(pr (symname (car x)))
(pr SP)
(let ((ind (if (and (eq 'cond (car x))
(willfit pr-cs (cdr x)))
6
2)))
(with ((offset (+ ind offset)))
(cond ((eq (car x) 'case)
(pp-inline (cadr x))
(linefeed)))
(let ((cs (if (eq (car x) 'cond)
(cdr x)
(cddr x))))
(pr-cs cs)
(pr RP))))))
(defun (pp-def x)
(pr LP)
(pr (symname (car x)))
(pr SP)
(pp-inline (cadr x))
(with ((offset (+ 2 offset)))
(if (or (and (pair (caddr x))
(eq 'lambda (caaddr x)))
(pair (cadr x))
(bleedp x))
(linefeed)
(pr SP))
(pp-body (cddr x)))
(pr RP))
(defun (pp-comm x)
(cond ((and (pair (cdr x))
(null (cddr x))
(stringp (cadr x)))
(pr ";")
(pr (cadr x))
(linefeed))
(else
(pp-app x))))
(defun (pp-form x)
(cond ((not (pair x))
(pp-obj x))
((and (pair (car x))
(eq 'lambda (caar x)))
(pp-lamapp x))
(else
(case (car x)
((quote) (pp-quote x))
((qquote unquote splice) (pp-qquote x))
((lambda) (pp-lambda x))
((cond case) (pp-cond x))
((do) (pp-do x))
((if if* and or prog) (pp-down x))
((let let* labels with) (pp-bind x))
((def defun macro defmac) (pp-def x))
((--) (pp-comm x))
((setq) (pp-app x))
(else (pp-app x))))))
(pp-form x)
nil)
(def pp grind)

74
src/hash.ls9 Normal file
View File

@ -0,0 +1,74 @@
(defun (htsize n)
(cond ((<= n 101) 101)
((<= n 199) 199)
((<= n 499) 499)
((<= n 997) 997)
((<= n 1997) 1997)
((<= n 4999) 4999)
((<= n 9973) 9973)
(else 19997)))
(defun (mkht z)
(cons 0 (mkvec (htsize z) nil)))
(defun (hash x k)
(let* ((s (symname x))
(ks (ssize s)))
(let loop ((h 0)
(i 0))
(if (>= i ks)
h
(loop (rem (+ (* 31 h) (charval (sref s i)))
k)
(+ 1 i))))))
(defun (htref h k)
(let ((i (hash k (vsize (cdr h)))))
(cond ((assq k (vref (cdr h) i))
=> cdr)
(else
nil))))
(defun (htgrow h)
(let* ((k (htsize (+ 1 (vsize (cdr h)))))
(h* (mkht k)))
(let loop ((i 0)
(k (vsize (cdr h))))
(cond ((>= i k)
(setcar h (car h*))
(setcdr h (cdr h*)))
(else
(foreach (lambda (x)
(htset h* (car x) (cdr x)))
(vref (cdr h) i))
(loop (+ 1 i) k))))))
(defun (htset h k v)
(if (> (car h) (vsize (cdr h)))
(htgrow h))
(let ((i (hash k (vsize (cdr h)))))
(cond ((assq k (vref (cdr h) i))
=> (lambda (x)
(setcdr x v)))
(else
(setcar h (+ 1 (car h)))
(vset (cdr h)
i
(cons (cons k v)
(vref (cdr h) i)))))))
(defun (htdel h k)
(let ((i (hash k (vsize (cdr h)))))
(cond ((null (vref (cdr h) i))
nil)
((eq k (caar (vref (cdr h) i)))
(vset (cdr h) i (cdr (vref (cdr h) i)))
t)
(else
(let loop ((as (vref (cdr h) i)))
(cond ((null as) nil)
((eq k (caadr as))
(setcdr as (cddr as))
t)
((null (cdr as)) nil)
(else (loop (cdr as)))))))))

139
src/help.ls9 Normal file
View File

@ -0,0 +1,139 @@
;;; LISP9 HELP
;;; Nils M Holm, 2018
;;; In the public domain
(def *ttylines* 24)
(defun (help . s)
(def helpfile "lisp9.txt")
(def line 0)
(def first t)
(defun (subs= u n s)
(let ((ku (ssize u))
(ks (ssize s)))
(and (>= ks (+ n ku))
(si= u (substr s n (+ n ku))))))
(defun (findstri u s)
(let ((ku (ssize u))
(ks (ssize s)))
(let loop ((i 0))
(cond ((> i (- ks ku)) nil)
((si= u (substr s i (+ i ku))) i)
(else (loop (+ 1 i)))))))
(defun (topicp s ln)
(or (and (s= "" s)
(subs= "\t-- " 0 ln))
(subs= (sconc "\t-- \50" s " ") 0 ln)
(subs= (sconc "\t-- \50" s ")") 0 ln)
(subs= (sconc "\t-- " s " ") 0 ln)))
(defun (headlnp s ln)
(subs= (sconc "\t** " s) 0 ln))
(defun (trim s)
(do ((i (- (ssize s) 1) (- i 1)))
((or (< i 0)
(not (c= #\sp (sref s i))))
(do ((j 0 (+ 1 j)))
((or (>= j i)
(not (c= #\sp (sref s j))))
(substr s j (+ 1 i)))))))
(defun (trimhd s)
(do ((i (- (ssize s) 1) (- i 1)))
((and (not (c= #\- (sref s i)))
(not (c= #\* (sref s i))))
(substr s 4 (+ 1 i)))))
(defun (more)
(setq line (+ 1 line))
(cond ((or (= 0 *ttylines*)
(< (+ 2 line) *ttylines*)))
(else
(setq line 0)
(princ "-- more (q=quit) --")
(if first (readln))
(setq first nil)
(let ((s (readln)))
(and (not (eofp s))
(not (memv #\q (strlist s))))))))
(defun (princln s)
(cond ((more)
(princ s)
(terpri))
(else
nil)))
(defun (toc s)
(let* ((s (substr s 2 (ssize s)))
(s (trim s))
(kw (if (s= "" s) nil s))
(kf nil))
(with-inport helpfile
(lambda (h)
(let loop ((s (readln h)))
(cond ((eofp s))
((topicp "" s)
(if (or kf (not kw))
(if (princln (trimhd s))
(loop (readln h)))
(loop (readln h))))
((headlnp "" s)
(cond (kf)
((or (not kw)
(findstri kw s))
(if kw (setq kf t))
(if (and (princln "")
(princln (trimhd s)))
(loop (readln h))))
(else
(loop (readln h)))))
(else
(loop (readln h)))))))))
(defun (extract h s)
(let loop ((s1 (readln h))
(s2 s))
(cond ((eofp s1))
((eofp s2)
(princln s1))
((and (s= "" s1)
(s= "" s2)))
((princln s2)
(loop (readln h) s1)))))
(defun (topic top)
(with-inport helpfile
(lambda (h)
(let loop ((s (readln h))
(tops nil))
(cond ((eofp s))
((topicp top s)
(do ((a (nrever tops) (cdr a)))
((null a))
(princln (car a)))
(extract h s))
((topicp "" s)
(loop (readln h)
(cons s tops)))
(else
(loop (readln h) nil)))))))
(defun (usage)
(princ
(sconc
",h topic = describe topic\n"
",h,t = table of contents\n"
",h,t chapter = list chapter\n"))
t)
(let ((s (if (null s) nil (car s))))
(cond ((null s) (usage))
((subs= ",t" 0 s) (toc s))
(else (topic s)))))

7
src/iota.ls9 Normal file
View File

@ -0,0 +1,7 @@
(defun (iota x y)
(defun (iota3 x y r)
(if (>= x y)
(nrever r)
(iota3 (+ 1 x) y (cons x r))))
(iota3 x y nil))

16
src/ltak.ls9 Normal file
View File

@ -0,0 +1,16 @@
(labels
((tak (lambda (x y z)
(if (not-longer x y)
z
(tak (tak (cdr x) y z)
(tak (cdr y) z x)
(tak (cdr z) x y)))))
(not-longer (lambda (a b)
(if (eq a nil)
t
(if (eq b nil)
nil
(not-longer (cdr a) (cdr b)))))))
(tak '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18)
'(1 2 3 4 5 6 7 8 9 10 11 12)
'(1 2 3 4 5 6)))

78
src/meta.ls9 Normal file
View File

@ -0,0 +1,78 @@
(defmac (label x f)
@(labels ((,x ,f)) ,x))
(def xeval
(quote
(label xeval
(lambda (x e)
(cond ((atom x)
((label assoc
(lambda (x a)
(cond ((eq nil a) nil)
((eq x (caar a))
(cadr (car a)))
(t (assoc x (cdr a))))))
x e))
((atom (car x))
(cond ((eq (car x) (quote quote))
(cadr x))
((eq (car x) (quote atom))
(atom (xeval (cadr x) e)))
((eq (car x) (quote eq))
(eq (xeval (cadr x) e)
(xeval (cadr (cdr x)) e)))
((eq (car x) (quote car))
(car (xeval (cadr x) e)))
((eq (car x) (quote cdr))
(cdr (xeval (cadr x) e)))
((eq (car x) (quote caar))
(car (car (xeval (cadr x) e))))
((eq (car x) (quote cadr))
(car (cdr (xeval (cadr x) e))))
((eq (car x) (quote cons))
(cons (xeval (cadr x) e)
(xeval (cadr (cdr x)) e)))
((eq (car x) (quote cond))
((label evcon
(lambda (c e)
(cond ((xeval (caar c) e)
(xeval (cadr (car c)) e))
(t (evcon (cdr c) e)))))
(cdr x) e))
(t (xeval (cons (xeval (car x) e)
(cdr x))
e))))
((eq (caar x) (quote lambda))
(xeval
(cadr (cdr (car x)))
((label bind
(lambda (v a ee)
(cond ((eq v nil) ee)
(t (bind
(cdr v)
(cdr a)
(cons (cons (car v)
(cons (xeval (car a) e)
nil))
ee))))))
(cadr (car x)) (cdr x) e)))
((eq (caar x) (quote label))
(xeval (cons (cadr (cdr (car x))) (cdr x))
(cons (cons (cadr (car x)) (cons (car x) nil))
e))))))))
(def append
'((label append
(lambda (a b)
(cond ((eq a nil) b)
(t (cons (car a)
(append (cdr a)
b))))))
(quote (a b c))
(quote (d e f))))
; (print ((eval xeval) append '((t t))))
; (print ((eval xeval) @(,xeval ',append '((t t))) `((t t))))
; (print ((eval xeval) @(,xeval '(,xeval ',append '((t t))) '((t t))) '((t t))))

6
src/nreconc.ls9 Normal file
View File

@ -0,0 +1,6 @@
(defun (nreconc n m)
(if (null n)
m
(let ((h (cdr n)))
(setcdr n m)
(nreconc h n))))

211
src/print.ls9 Normal file
View File

@ -0,0 +1,211 @@
;;; Page Formatter
;;; Nils M Holm, 2018
;;; In the public domain
(def plen 72)
(def llen 80)
(def outp (outport))
(def lead 4)
(def margin 0)
(def title "")
(def troff nil)
(def dotoc nil)
(def line 1)
(def page 1)
(def toc nil)
(defun (expand s)
(let ((k (ssize s)))
(let loop ((i 0)
(j 0)
(x nil))
(cond ((>= i k)
(liststr (nrever x)))
((c= #\ht (sref s i))
(let tab ((n (- 8 (rem j 8)))
(j j)
(x x))
(cond ((= 0 n)
(loop (+ 1 i) j x))
(else
(tab (- n 1) (+ 1 j) (cons #\sp x))))))
(else
(loop (+ 1 i) (+ 1 j) (cons (sref s i) x)))))))
(defun (escape s)
(let ((k (ssize s)))
(let loop ((i 0)
(x (list #\& #\\)))
(cond ((>= i k)
(liststr (nrever x)))
((c= #\\ (sref s i))
(loop (+ 1 i) (cons #\\ (cons #\\ x))))
(else
(loop (+ 1 i) (cons (sref s i) x)))))))
(defun (output s)
(princ s outp))
(defun (spaces n)
(cond ((not (= 0 n))
(output " ")
(spaces (- n 1)))))
(defun (header)
(output "\n")
(spaces (div (- (+ llen margin) (ssize title)) 2))
(output title)
(do ((i 0 (+ 1 i)))
((= i (- lead 2)))
(output "\n")))
(defun (footer)
(do ((i 0 (+ 1 i)))
((= i (- lead 2)))
(output "\n"))
(let ((s (format page)))
(spaces (div (- (+ llen margin) 6 (ssize s)) 2))
(output "-- ")
(output s)
(if troff
(output " --\n.bp\n")
(output " --\14"))
(setq page (+ 1 page))))
(defun (break)
(footer)
(header)
(setq line 1))
(defun (prline s)
(if (> line (- plen (* 2 lead)))
(break))
(setq line (+ 1 line))
(if (> margin 0) (spaces margin))
(let* ((s (if troff
(escape (expand s))
(expand s)))
(k (ssize s))
(s (if (< margin 0)
(if (< k (- margin))
""
(substr s (- margin) (ssize s)))
s)))
(output s)
(terpri outp)))
(defun (fillpage)
(do ((x line (+ 1 x)))
((>= x (- plen (* 2 lead))))
(prline "")))
(defun (prfile)
(header)
(let loop ((s (readln)))
(cond ((eofp s))
(else
(if (and (>= (ssize s) 4)
(s= "\t** " (substr s 0 4)))
(setq toc (cons (list s page (sref s 1))
toc)))
(prline s)
(loop (readln))))))
(defun (trim s)
(let ((s (substr s 4 (ssize s))))
(let loop ((i (- (ssize s) 1)))
(if (or (c= #\* (sref s i))
(c= #\- (sref s i)))
(loop (- i 1))
(let loop ((i i))
(if (c= #\sp (sref s i))
(loop (- i 1))
(substr s 0 (+ 1 i))))))))
(defun (prtoc)
(defun (entry s)
(prline (sconc (if (c= (caddr s) #\*) "\n" "")
" "
(numstr (cadr s))
" "
(trim (car s)))))
(fillpage)
(break)
(prline " TABLE OF CONTENTS")
(prline "")
(foreach entry (nrever toc)))
(defun (prolog)
(cond (troff
(foreach
(lambda (x) (princ x) (terpri))
'(".nf"
".ft CB"
".ps 11"
".vs 13")))))
(defun (usage)
(set-outport (errport))
(princ
(sconc
"Usage: print [-l leading-space]\n"
" [-n line-length]\n"
" [-m left-margin]\n"
" [-o output-file]\n"
" [-p paper-length]\n"
" [-t document-title]\n"
" [-C] write contents\n"
" [-T] TROFF output\n"
" [file ...]\n"))
(quit))
(defun (opt o)
(if (null (cdr o))
(usage)
(cadr o)))
(defun (getopts)
(let loop ((o (cmdline)))
(cond ((null o)
nil)
((not (c= #\- (sref (car o) 0)))
o)
((s= "-l" (car o))
(setq lead (strnum (opt o)))
(loop (cddr o)))
((s= "-m" (car o))
(setq margin (strnum (opt o)))
(loop (cddr o)))
((s= "-n" (car o))
(setq llen (strnum (opt o)))
(loop (cddr o)))
((s= "-o" (car o))
(setq outp (open-outfile (opt o)))
(loop (cddr o)))
((s= "-p" (car o))
(setq plen (strnum (opt o)))
(loop (cddr o)))
((s= "-t" (car o))
(setq title (opt o))
(loop (cddr o)))
((s= "-C" (car o))
(setq dotoc t)
(loop (cdr o)))
((s= "-T" (car o))
(setq troff t)
(loop (cdr o)))
(else
(usage)))))
(let ((f (getopts)))
(prolog)
(if (null f)
(prfile)
(let loop ((f f))
(cond ((not (null f))
(with-infile (car f) prfile)
(loop (cdr f))))))
(if dotoc (prtoc))
(fillpage)
(footer))

14
src/repl.ls9 Normal file
View File

@ -0,0 +1,14 @@
;; repl by Fulton Browne
(defun (prompt) ;; think of this as the $PS1
(princ "> ")
(flush (outport)) ;; this is dumb
)
(defun (repl)
(prompt)
(setq in (read))
(if (or (equal in 'exit) (eofp in)) (error "good bye!"))
(print (catch-errors () (eval in)))
(repl))
(defun (start-repl)
(print 'starting "FREPLv1.0")
(repl))

8
src/start.ls9 Normal file
View File

@ -0,0 +1,8 @@
(defun (start)
(cond ((not *quiet*)
(let ((g (gc)))
(terpri)
(princ (car g))
(princ " NODES\n")
(princ (cadr g))
(princ " VCELLS\n\n")))))

2374
test.ls9 Normal file
View File

File diff suppressed because it is too large Load Diff