sjs/sectorlisp
1
0
Fork 0
mirror of https://github.com/samsonjs/sectorlisp.git synced 2026-04-27 14:57:41 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Create reform branch (429 bytes)

Browse source
This commit is contained in:
Justine Tunney 2021-11-26 09:50:37 -08:00
parent 920babb3e7
commit 106c07c25a
3 changed files with 75 additions and 97 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
lisp.c
View file

@ -33,15 +33,14 @@
#define kT 4 #define kT 4
#define kQuote 6 #define kQuote 6
#define kCond 12 #define kAtom 12
#define kAtom 17 #define kCar 17
#define kCar 22 #define kCdr 21
#define kCdr 26 #define kCons 25
#define kCons 30 #define kEq 30
#define kEq 35
#define M (RAM + sizeof(RAM) / sizeof(RAM[0]) / 2) #define M (RAM + sizeof(RAM) / sizeof(RAM[0]) / 2)
#define S "NIL\0T\0QUOTE\0COND\0ATOM\0CAR\0CDR\0CONS\0EQ" #define S "NIL\0T\0QUOTE\0ATOM\0CAR\0CDR\0CONS\0EQ"
int cx; /* stores negative memory use */ int cx; /* stores negative memory use */
int dx; /* stores lookahead character */ int dx; /* stores lookahead character */
@ -125,22 +124,24 @@ PrintAtom(x) {
PrintList(x) { PrintList(x) {
PrintChar('('); PrintChar('(');
PrintObject(Car(x)); if (x) {
while ((x = Cdr(x))) { PrintObject(Car(x));
if (x < 0) { while ((x = Cdr(x))) {
PrintChar(' '); if (x < 0) {
PrintObject(Car(x)); PrintChar(' ');
} else { PrintObject(Car(x));
PrintChar(L'∙'); } else {
PrintObject(x); PrintChar(L'∙');
break; PrintObject(x);
break;
}
} }
} }
PrintChar(')'); PrintChar(')');
} }
PrintObject(x) { PrintObject(x) {
if (x < 0) { if (1./x < 0) {
PrintList(x); PrintList(x);
} else { } else {
PrintAtom(x); PrintAtom(x);
@ -186,7 +187,6 @@ Pairlis(x, y, a) {
} }
Assoc(x, y) { Assoc(x, y) {
if (!y) return 0;
if (x == Car(Car(y))) return Cdr(Car(y)); if (x == Car(Car(y))) return Cdr(Car(y));
return Assoc(x, Cdr(y)); return Assoc(x, Cdr(y));
} }
@ -200,7 +200,7 @@ Evcon(c, a) {
} }
Apply(f, x, a) { Apply(f, x, a) {
if (f < 0) return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(f)), x, a)); if (f < 0) return Evcon(Cdr(f), Pairlis(Car(f), x, a));
if (f > kEq) return Apply(Eval(f, a), x, a); if (f > kEq) return Apply(Eval(f, a), x, a);
if (f == kEq) return Car(x) == Car(Cdr(x)) ? kT : 0; if (f == kEq) return Car(x) == Car(Cdr(x)) ? kT : 0;
if (f == kCons) return Cons(Car(x), Car(Cdr(x))); if (f == kCons) return Cons(Car(x), Car(Cdr(x)));
@ -211,21 +211,13 @@ Apply(f, x, a) {
Eval(e, a) { Eval(e, a) {
int A, B, C; int A, B, C;
if (e >= 0) if (!e) return 0;
return Assoc(e, a); if (e > 0) return Assoc(e, a);
if (Car(e) == kQuote) if (Car(e) == kQuote) return Car(Cdr(e));
return Car(Cdr(e)); A = cx, e = Apply(Car(e), Evlis(Cdr(e), a), a);
A = cx; B = cx, e = Gc(e, A, A - B);
if (Car(e) == kCond) {
e = Evcon(Cdr(e), a);
} else {
e = Apply(Car(e), Evlis(Cdr(e), a), a);
}
B = cx;
e = Gc(e, A, A - B);
C = cx; C = cx;
while (C < B) while (C < B) M[--A] = M[--B];
M[--A] = M[--B];
cx = A; cx = A;
return e; return e;
} }

103
lisp.lisp
View file

@ -61,62 +61,53 @@ NIL
;; FIND FIRST ATOM IN TREE ;; FIND FIRST ATOM IN TREE
;; CORRECT RESULT OF EXPRESSION IS `A` ;; CORRECT RESULT OF EXPRESSION IS `A`
;; RECURSIVE CONDITIONAL FUNCTION BINDING ;; RECURSIVE CONDITIONAL FUNCTION BINDING
((LAMBDA (FF X) (FF X)) (((FF X)
(QUOTE (LAMBDA (X) ((QUOTE T) (FF X)))
(COND ((ATOM X) X) (QUOTE ((X)
((QUOTE T) (FF (CAR X)))))) ((ATOM X) X)
((QUOTE T) (FF (CAR X)))))
(QUOTE ((A) B C))) (QUOTE ((A) B C)))
;; LISP IMPLEMENTED IN LISP ;; LISP IN LISP
;; WITHOUT ANY SUBJECTIVE SYNTACTIC SUGAR ;; WITH LANGUAGE REFORMS
;; RUNS "FIND FIRST ATOM IN TREE" PROGRAM (((ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
;; CORRECT RESULT OF EXPRESSION IS STILL `A` ((QUOTE T)
;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND (EVAL (QUOTE (((FF X)
;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER ((QUOTE T) (FF X)))
;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP (QUOTE ((X)
;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE ((ATOM X) X)
((LAMBDA (ASSOC EVCON PAIRLIS EVLIS APPLY EVAL) ((QUOTE T) (FF (CAR X)))))
(EVAL (QUOTE ((LAMBDA (FF X) (FF X))
(QUOTE (LAMBDA (X)
(COND ((ATOM X) X)
((QUOTE T) (FF (CAR X))))))
(QUOTE ((A) B C)))) (QUOTE ((A) B C))))
())) ())))
(QUOTE (LAMBDA (X Y) (QUOTE ((X Y)
(COND ((EQ Y ()) ()) ((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
((EQ X (CAR (CAR Y))) ((QUOTE T) (ASSOC X (CDR Y)))))
(CDR (CAR Y))) (QUOTE ((C A)
((QUOTE T) ((EVAL (CAR (CAR C)) A)
(ASSOC X (CDR Y)))))) (EVAL (CAR (CDR (CAR C))) A))
(QUOTE (LAMBDA (C A) ((QUOTE T) (EVCON (CDR C) A))))
(COND ((EVAL (CAR (CAR C)) A) (QUOTE ((X Y A)
(EVAL (CAR (CDR (CAR C))) A)) ((EQ X ()) A)
((QUOTE T) (EVCON (CDR C) A))))) ((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
(QUOTE (LAMBDA (X Y A) (PAIRLIS (CDR X) (CDR Y) A)))))
(COND ((EQ X ()) A) (QUOTE ((M A)
((QUOTE T) (CONS (CONS (CAR X) (CAR Y)) ((EQ M ()) ())
(PAIRLIS (CDR X) (CDR Y) A)))))) ((QUOTE T) (CONS (EVAL (CAR M) A)
(QUOTE (LAMBDA (M A) (EVLIS (CDR M) A)))))
(COND ((EQ M ()) ()) (QUOTE ((FN X A)
((QUOTE T) (CONS (EVAL (CAR M) A) ((ATOM FN)
(EVLIS (CDR M) A)))))) ((() ((EQ FN (QUOTE CAR)) (CAR (CAR X)))
(QUOTE (LAMBDA (FN X A) ((EQ FN (QUOTE CDR)) (CDR (CAR X)))
(COND ((EQ FN (QUOTE ATOM)) (ATOM (CAR X)))
((ATOM FN) ((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X))))
(COND ((EQ FN (QUOTE CAR)) (CAR (CAR X))) ((EQ FN (QUOTE EQ)) (EQ (CAR X) (CAR (CDR X))))
((EQ FN (QUOTE CDR)) (CDR (CAR X))) ((QUOTE T) (APPLY (EVAL FN A) X A)))))
((EQ FN (QUOTE ATOM)) (ATOM (CAR X))) ((QUOTE T)
((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X)))) (EVCON (CDR FN) (PAIRLIS (CAR FN) X A)))))
((EQ FN (QUOTE EQ)) (EQ (CAR X) (CAR (CDR X)))) (QUOTE ((E A)
((QUOTE T) (APPLY (EVAL FN A) X A)))) ((EQ E ()) ())
((EQ (CAR FN) (QUOTE LAMBDA)) ((ATOM E) (ASSOC E A))
(EVAL (CAR (CDR (CDR FN))) ((ATOM (CAR E))
(PAIRLIS (CAR (CDR FN)) X A)))))) ((() ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
(QUOTE (LAMBDA (E A) ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A)))))
(COND ((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A)))))
((ATOM E) (ASSOC E A))
((ATOM (CAR E))
(COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))))

11
sectorlisp.S
View file

@ -29,7 +29,6 @@ kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
.asciz "" .asciz ""
kQuote: .asciz "QUOTE" kQuote: .asciz "QUOTE"
kCond: .asciz "COND"
kAtom: .asciz "ATOM" # ordering matters kAtom: .asciz "ATOM" # ordering matters
kCar: .asciz "CAR" # ordering matters kCar: .asciz "CAR" # ordering matters
kCdr: .asciz "CDR" # ordering matters kCdr: .asciz "CDR" # ordering matters
@ -205,13 +204,12 @@ GetList:call GetToken
Apply: test %ax,%ax # Apply(fn:ax,x:si:a:dx):ax Apply: test %ax,%ax # Apply(fn:ax,x:si:a:dx):ax
jns .switch # jump if atom jns .switch # jump if atom
xchg %ax,%di # di = fn xchg %ax,%di # di = fn
.lambda:mov (%bx,%di),%di # di = Cdr(fn) .lambda:push (%bx,%di) # save 1
push %di # save 1
mov (%di),%di # di = Cadr(fn) mov (%di),%di # di = Cadr(fn)
call Pairlis call Pairlis
xchg %ax,%dx xchg %ax,%dx
pop %di # restore 1 pop %di # restore 1
jmp .EvCadr jmp Evcon
.switch:cmp $kEq,%ax # eq is last builtin atom .switch:cmp $kEq,%ax # eq is last builtin atom
ja .dflt1 # ah is zero if not above ja .dflt1 # ah is zero if not above
mov (%si),%di # di = Car(x) mov (%si),%di # di = Car(x)
@ -255,7 +253,7 @@ Evcon: push %di # save c
test %ax,%ax # nil test test %ax,%ax # nil test
jz 1b jz 1b
mov (%di),%di # di = Car(c) mov (%di),%di # di = Car(c)
.EvCadr:call Cadr # ax = Cadar(c) call Cadr # ax = Cadar(c)
# jmp Eval # jmp Eval
Eval: test %ax,%ax # Eval(e:ax,a:dx):ax Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
@ -266,8 +264,6 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
cmp $kQuote,%ax # maybe CONS cmp $kQuote,%ax # maybe CONS
mov (%si),%di # di = Cdr(e) mov (%si),%di # di = Cdr(e)
je Car je Car
cmp $kCond,%ax
je Evcon # ABC Garbage Collector
push %dx # save a push %dx # save a
push %cx # save A push %cx # save A
push %ax push %ax
@ -291,7 +287,6 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
.word 0xAA55 .word 0xAA55
2: .type .sig,@object 2: .type .sig,@object
.type kQuote,@object .type kQuote,@object
.type kCond,@object
.type kAtom,@object .type kAtom,@object
.type kCar,@object .type kCar,@object
.type kCdr,@object .type kCdr,@object