mirror of
https://github.com/samsonjs/sectorlisp.git
synced 2026-03-25 09:05:48 +00:00
Create reform branch (429 bytes)
This commit is contained in:
Justine Tunney
parent
920babb3e7
commit
106c07c25a
3 changed files with 75 additions and 97 deletions
40
lisp.c
40
lisp.c
|
|
@ -33,15 +33,14 @@
|
|||
|
||||
#define kT 4
|
||||
#define kQuote 6
|
||||
#define kCond 12
|
||||
#define kAtom 17
|
||||
#define kCar 22
|
||||
#define kCdr 26
|
||||
#define kCons 30
|
||||
#define kEq 35
|
||||
#define kAtom 12
|
||||
#define kCar 17
|
||||
#define kCdr 21
|
||||
#define kCons 25
|
||||
#define kEq 30
|
||||
|
||||
#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 dx; /* stores lookahead character */
|
||||
|
|
@ -125,6 +124,7 @@ PrintAtom(x) {
|
|||
|
||||
PrintList(x) {
|
||||
PrintChar('(');
|
||||
if (x) {
|
||||
PrintObject(Car(x));
|
||||
while ((x = Cdr(x))) {
|
||||
if (x < 0) {
|
||||
|
|
@ -136,11 +136,12 @@ PrintList(x) {
|
|||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
PrintChar(')');
|
||||
}
|
||||
|
||||
PrintObject(x) {
|
||||
if (x < 0) {
|
||||
if (1./x < 0) {
|
||||
PrintList(x);
|
||||
} else {
|
||||
PrintAtom(x);
|
||||
|
|
@ -186,7 +187,6 @@ Pairlis(x, y, a) {
|
|||
}
|
||||
|
||||
Assoc(x, y) {
|
||||
if (!y) return 0;
|
||||
if (x == Car(Car(y))) return Cdr(Car(y));
|
||||
return Assoc(x, Cdr(y));
|
||||
}
|
||||
|
|
@ -200,7 +200,7 @@ Evcon(c, 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 Car(x) == Car(Cdr(x)) ? kT : 0;
|
||||
if (f == kCons) return Cons(Car(x), Car(Cdr(x)));
|
||||
|
|
@ -211,21 +211,13 @@ Apply(f, x, a) {
|
|||
|
||||
Eval(e, a) {
|
||||
int A, B, C;
|
||||
if (e >= 0)
|
||||
return Assoc(e, a);
|
||||
if (Car(e) == kQuote)
|
||||
return Car(Cdr(e));
|
||||
A = cx;
|
||||
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);
|
||||
if (!e) return 0;
|
||||
if (e > 0) return Assoc(e, a);
|
||||
if (Car(e) == kQuote) return Car(Cdr(e));
|
||||
A = cx, e = Apply(Car(e), Evlis(Cdr(e), a), a);
|
||||
B = cx, e = Gc(e, A, A - B);
|
||||
C = cx;
|
||||
while (C < B)
|
||||
M[--A] = M[--B];
|
||||
while (C < B) M[--A] = M[--B];
|
||||
cx = A;
|
||||
return e;
|
||||
}
|
||||
|
|
|
|||
83
lisp.lisp
83
lisp.lisp
|
|
@ -61,62 +61,53 @@ NIL
|
|||
;; FIND FIRST ATOM IN TREE
|
||||
;; CORRECT RESULT OF EXPRESSION IS `A`
|
||||
;; RECURSIVE CONDITIONAL FUNCTION BINDING
|
||||
((LAMBDA (FF X) (FF X))
|
||||
(QUOTE (LAMBDA (X)
|
||||
(COND ((ATOM X) X)
|
||||
((QUOTE T) (FF (CAR X))))))
|
||||
(((FF X)
|
||||
((QUOTE T) (FF X)))
|
||||
(QUOTE ((X)
|
||||
((ATOM X) X)
|
||||
((QUOTE T) (FF (CAR X)))))
|
||||
(QUOTE ((A) B C)))
|
||||
|
||||
;; LISP IMPLEMENTED IN LISP
|
||||
;; WITHOUT ANY SUBJECTIVE SYNTACTIC SUGAR
|
||||
;; RUNS "FIND FIRST ATOM IN TREE" PROGRAM
|
||||
;; CORRECT RESULT OF EXPRESSION IS STILL `A`
|
||||
;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND
|
||||
;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER
|
||||
;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP
|
||||
;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE
|
||||
((LAMBDA (ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
|
||||
(EVAL (QUOTE ((LAMBDA (FF X) (FF X))
|
||||
(QUOTE (LAMBDA (X)
|
||||
(COND ((ATOM X) X)
|
||||
((QUOTE T) (FF (CAR X))))))
|
||||
(QUOTE ((A) B C))))
|
||||
()))
|
||||
(QUOTE (LAMBDA (X Y)
|
||||
(COND ((EQ Y ()) ())
|
||||
((EQ X (CAR (CAR Y)))
|
||||
(CDR (CAR Y)))
|
||||
;; LISP IN LISP
|
||||
;; WITH LANGUAGE REFORMS
|
||||
(((ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
|
||||
((QUOTE T)
|
||||
(ASSOC X (CDR Y))))))
|
||||
(QUOTE (LAMBDA (C A)
|
||||
(COND ((EVAL (CAR (CAR C)) A)
|
||||
(EVAL (QUOTE (((FF X)
|
||||
((QUOTE T) (FF X)))
|
||||
(QUOTE ((X)
|
||||
((ATOM X) X)
|
||||
((QUOTE T) (FF (CAR X)))))
|
||||
(QUOTE ((A) B C))))
|
||||
())))
|
||||
(QUOTE ((X Y)
|
||||
((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
|
||||
((QUOTE T) (ASSOC X (CDR Y)))))
|
||||
(QUOTE ((C A)
|
||||
((EVAL (CAR (CAR C)) A)
|
||||
(EVAL (CAR (CDR (CAR C))) A))
|
||||
((QUOTE T) (EVCON (CDR C) A)))))
|
||||
(QUOTE (LAMBDA (X Y A)
|
||||
(COND ((EQ X ()) A)
|
||||
((QUOTE T) (EVCON (CDR C) A))))
|
||||
(QUOTE ((X Y A)
|
||||
((EQ X ()) A)
|
||||
((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
|
||||
(PAIRLIS (CDR X) (CDR Y) A))))))
|
||||
(QUOTE (LAMBDA (M A)
|
||||
(COND ((EQ M ()) ())
|
||||
(PAIRLIS (CDR X) (CDR Y) A)))))
|
||||
(QUOTE ((M A)
|
||||
((EQ M ()) ())
|
||||
((QUOTE T) (CONS (EVAL (CAR M) A)
|
||||
(EVLIS (CDR M) A))))))
|
||||
(QUOTE (LAMBDA (FN X A)
|
||||
(COND
|
||||
(EVLIS (CDR M) A)))))
|
||||
(QUOTE ((FN X A)
|
||||
((ATOM FN)
|
||||
(COND ((EQ FN (QUOTE CAR)) (CAR (CAR X)))
|
||||
((() ((EQ FN (QUOTE CAR)) (CAR (CAR X)))
|
||||
((EQ FN (QUOTE CDR)) (CDR (CAR X)))
|
||||
((EQ FN (QUOTE ATOM)) (ATOM (CAR X)))
|
||||
((EQ FN (QUOTE CONS)) (CONS (CAR X) (CAR (CDR X))))
|
||||
((EQ FN (QUOTE EQ)) (EQ (CAR X) (CAR (CDR X))))
|
||||
((QUOTE T) (APPLY (EVAL FN A) X A))))
|
||||
((EQ (CAR FN) (QUOTE LAMBDA))
|
||||
(EVAL (CAR (CDR (CDR FN)))
|
||||
(PAIRLIS (CAR (CDR FN)) X A))))))
|
||||
(QUOTE (LAMBDA (E A)
|
||||
(COND
|
||||
((QUOTE T) (APPLY (EVAL FN A) X A)))))
|
||||
((QUOTE T)
|
||||
(EVCON (CDR FN) (PAIRLIS (CAR FN) X A)))))
|
||||
(QUOTE ((E A)
|
||||
((EQ E ()) ())
|
||||
((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))))))
|
||||
((() ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
|
||||
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A)))))
|
||||
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A)))))
|
||||
|
|
|
|||
11
sectorlisp.S
11
sectorlisp.S
|
|
@ -29,7 +29,6 @@ kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
|
|||
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
|
||||
.asciz ""
|
||||
kQuote: .asciz "QUOTE"
|
||||
kCond: .asciz "COND"
|
||||
kAtom: .asciz "ATOM" # ordering matters
|
||||
kCar: .asciz "CAR" # 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
|
||||
jns .switch # jump if atom
|
||||
xchg %ax,%di # di = fn
|
||||
.lambda:mov (%bx,%di),%di # di = Cdr(fn)
|
||||
push %di # save 1
|
||||
.lambda:push (%bx,%di) # save 1
|
||||
mov (%di),%di # di = Cadr(fn)
|
||||
call Pairlis
|
||||
xchg %ax,%dx
|
||||
pop %di # restore 1
|
||||
jmp .EvCadr
|
||||
jmp Evcon
|
||||
.switch:cmp $kEq,%ax # eq is last builtin atom
|
||||
ja .dflt1 # ah is zero if not above
|
||||
mov (%si),%di # di = Car(x)
|
||||
|
|
@ -255,7 +253,7 @@ Evcon: push %di # save c
|
|||
test %ax,%ax # nil test
|
||||
jz 1b
|
||||
mov (%di),%di # di = Car(c)
|
||||
.EvCadr:call Cadr # ax = Cadar(c)
|
||||
call Cadr # ax = Cadar(c)
|
||||
# jmp Eval
|
||||
|
||||
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
|
||||
mov (%si),%di # di = Cdr(e)
|
||||
je Car
|
||||
cmp $kCond,%ax
|
||||
je Evcon # ABC Garbage Collector
|
||||
push %dx # save a
|
||||
push %cx # save A
|
||||
push %ax
|
||||
|
|
@ -291,7 +287,6 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
|
|||
.word 0xAA55
|
||||
2: .type .sig,@object
|
||||
.type kQuote,@object
|
||||
.type kCond,@object
|
||||
.type kAtom,@object
|
||||
.type kCar,@object
|
||||
.type kCdr,@object
|
||||
|
|
|
|||
Loading…
Reference in a new issue