sjs/sectorlisp
1
0
Fork 0
mirror of https://github.com/samsonjs/sectorlisp.git synced 2026-03-30 09:55:45 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Update code

Browse source
This commit is contained in:
Justine Tunney 2021-11-30 13:29:54 -08:00
parent 0f6b147099
commit 14873babc7
4 changed files with 126 additions and 386 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
Makefile
View file

@ -17,7 +17,7 @@ all: lisp \
clean:; $(RM) lisp lisp.o bestline.o sectorlisp.o sectorlisp.bin sectorlisp.bin.dbg
lisp: lisp.o bestline.o
lisp.o: lisp.c bestline.h
lisp.o: lisp.js bestline.h
bestline.o: bestline.c bestline.h
sectorlisp.o: sectorlisp.S
@ -28,3 +28,6 @@ sectorlisp.bin.dbg: sectorlisp.o
sectorlisp.bin: sectorlisp.bin.dbg
objcopy -S -O binary sectorlisp.bin.dbg sectorlisp.bin
%.o: %.js
$(COMPILE.c) -xc $(OUTPUT_OPTION) $<

274
lisp.c
View file

@ -1,274 +0,0 @@
/*-*- mode:c;indent-tabs-mode:nil;c-basic-offset:2;tab-width:8;coding:utf-8 -*-│
│vi: set net ft=c ts=2 sts=2 sw=2 fenc=utf-8 :vi│
╞══════════════════════════════════════════════════════════════════════════════╡
│ Copyright 2020 Justine Alexandra Roberts Tunney │
│ │
│ Permission to use, copy, modify, and/or distribute this software for │
│ any purpose with or without fee is hereby granted, provided that the │
│ above copyright notice and this permission notice appear in all copies. │
│ │
│ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL │
│ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED │
│ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE │
│ AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL │
│ DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR │
│ PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER │
│ TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR │
│ PERFORMANCE OF THIS SOFTWARE. │
╚─────────────────────────────────────────────────────────────────────────────*/
#include "bestline.h"
#ifndef __COSMOPOLITAN__
#include <stdio.h>
#include <locale.h>
#include <setjmp.h>
#endif
#define var int
#define function
#define Null 0100000
var M[Null * 2];
jmp_buf undefined;
var cx, dx, kT, kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote;
function Set(i, x) {
M[Null + i] = x;
}
function Get(i) {
return M[Null + i];
}
function Hash(h, c) {
return h + c * 2;
}
function Intern(x, y, i) {
i &= Null - 1;
if (x == Get(i) && y == Get(i + 1)) return i;
if (Get(i)) return Intern(x, y, i + 2);
Set(i, x);
Set(i + 1, y);
return i;
}
function ReadAtom(h) {
var c = ReadChar();
if (c <= Ord(' ')) return ReadAtom(h);
return Intern(c, c > Ord(')') && dx > Ord(')') ?
ReadAtom(Hash(h, c)) : 0,
Hash(h, c) - Hash(0, Ord('N')));
}
function PrintAtom(x) {
do PrintChar(Get(x));
while ((x = Get(x + 1)));
}
function AddList(x) {
return Cons(x, ReadList());
}
function ReadList() {
var t = ReadAtom(0);
if (Get(t) == Ord(')')) return -0;
return AddList(ReadObject(t));
}
function ReadObject(t) {
if (Get(t) != Ord('(')) return t;
return ReadList();
}
function PrintList(x) {
PrintChar(Ord('('));
if (x < 0) {
PrintObject(Car(x));
while ((x = Cdr(x))) {
if (x < 0) {
PrintChar(Ord(' '));
PrintObject(Car(x));
} else {
PrintChar(0x2219);
PrintObject(x);
break;
}
}
}
PrintChar(Ord(')'));
}
function PrintObject(x) {
if (1./x < 0) {
PrintList(x);
} else {
PrintAtom(x);
}
}
function Print(e) {
PrintObject(e);
PrintChar(Ord('\n'));
}
function Read() {
return ReadObject(ReadAtom(0));
}
function Car(x) {
if (x < 0) {
return Get(x);
} else {
Throw(x);
}
}
function Cdr(x) {
if (x < 0) {
return Get(x + 1);
} else {
Throw(x);
}
}
function Cons(car, cdr) {
Set(--cx, cdr);
Set(--cx, car);
return cx;
}
function Gc(A, x) {
var C, B = cx;
x = Copy(x, A, A - B), C = cx;
while (C < B) Set(--A, Get(--B));
cx = A;
return x;
}
function Copy(x, m, k) {
return x < m ? Cons(Copy(Car(x), m, k),
Copy(Cdr(x), m, k)) + k : x;
}
function Evlis(m, a) {
return m ? Cons(Eval(Car(m), a),
Evlis(Cdr(m), a)) : m;
}
function Pairlis(x, y, a) {
return x ? Cons(Cons(Car(x), Car(y)),
Pairlis(Cdr(x), Cdr(y), a)) : a;
}
function Assoc(x, y) {
if (y >= 0) Throw(x);
if (x == Car(Car(y))) return Cdr(Car(y));
return Assoc(x, Cdr(y));
}
function Evcon(c, a) {
if (Eval(Car(Car(c)), a)) {
return Eval(Car(Cdr(Car(c))), a);
} else if (Cdr(c)) {
return Evcon(Cdr(c), a);
} else {
Throw(c);
}
}
function Apply(f, x, a) {
if (f < 0) return Eval(Car(Cdr(Cdr(f))), Pairlis(Car(Cdr(f)), x, a));
if (f == kEq) return Car(x) == Car(Cdr(x)) ? kT : 0;
if (f == kCons) return Cons(Car(x), Car(Cdr(x)));
if (f == kAtom) return Car(x) < 0 ? 0 : kT;
if (f == kCar) return Car(Car(x));
if (f == kCdr) return Cdr(Car(x));
return Apply(Assoc(f, a), x, a);
}
function Eval(e, a) {
var A = cx;
if (!e) return 0;
if (e > 0) return Assoc(e, a);
if (Car(e) == kQuote) return Car(Cdr(e));
if (Car(e) == kCond) {
e = Evcon(Cdr(e), a);
} else {
e = Apply(Car(e), Evlis(Cdr(e), a), a);
}
return Gc(A, e);
}
function Lisp() {
var x, a;
ReadAtom(0);
kT = ReadAtom(0);
kCar = ReadAtom(0);
kCdr = ReadAtom(0);
kAtom = ReadAtom(0);
kCond = ReadAtom(0);
kCons = ReadAtom(0);
kQuote = ReadAtom(0);
kEq = ReadAtom(0);
for (a = 0;;) {
if (!(x = setjmp(undefined))) {
x = Read();
x = Eval(x, a);
if (x < 0) {
a = Cons(x, a);
}
} else {
PrintChar(63);
}
Print(x);
}
}
Ord(c) {
return c;
}
Throw(x) {
longjmp(undefined, x);
}
PrintChar(b) {
fputwc(b, stdout);
}
ReadChar() {
int b, c, t;
static char *freeme;
static char *line = "NIL T CAR CDR ATOM COND CONS QUOTE EQ ";
if (line || (line = freeme = bestlineWithHistory("* ", "sectorlisp"))) {
if (*line) {
c = *line++ & 0377;
if (c >= 0300) {
for (b = 0200; c & b; b >>= 1) c ^= b;
while ((*line & 0300) == 0200) {
c <<= 6;
c |= *line++ & 0177;
}
}
} else {
free(freeme);
freeme = 0;
line = 0;
c = Ord('\n');
}
t = dx;
dx = c;
return t;
} else {
PrintChar(Ord('\n'));
exit(0);
}
}
main() {
setlocale(LC_ALL, "");
bestlineSetXlatCallback(bestlineUppercase);
Lisp();
}

117
lisp.lisp
View file

@ -69,70 +69,69 @@ NIL
(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))
(LAMBDA (X)
(COND ((ATOM X) X)
(T (FF (CAR X)))))
(QUOTE ((A) B C))))
NIL))
(QUOTE (LAMBDA (X Y)
(COND ((EQ Y NIL) (QUOTE *UNDEFINED))
((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
((QUOTE T) (ASSOC X (CDR Y))))))
(QUOTE (LAMBDA (C A)
(COND ((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 NIL) A)
((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
(PAIRLIS (CDR X) (CDR Y) A))))))
(QUOTE (LAMBDA (M A)
(COND ((EQ M NIL) M)
((QUOTE T) (CONS (EVAL (CAR M) A)
(EVLIS (CDR M) A))))))
(QUOTE (LAMBDA (FN X A)
(COND
((ATOM FN)
(COND ((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
((ATOM E)
(COND ((EQ E NIL) E)
((EQ E (QUOTE T)) (QUOTE T))
((QUOTE T) (ASSOC E A))))
((ATOM (CAR E))
(COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
((EQ (CAR E) (QUOTE LAMBDA)) E)
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))))
(CONS (QUOTE NOT)
(QUOTE (LAMBDA (X)
(COND (X (QUOTE F))
((QUOTE T) (QUOTE T))))))
DEFINE ASSOC
(LAMBDA (X Y)
(COND ((EQ Y NIL) (QUOTE *UNDEFINED))
((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
((QUOTE T) (ASSOC X (CDR Y)))))
((LAMBDA (X E C)
(CONS (QUOTE LAMBDA) (CONS NIL (CONS (CAR (CDR C)) NIL))))
(QUOTE T)
(QUOTE (LAMBDA (F) (F)))
(QUOTE (COND (X (QUOTE F))
((QUOTE T) (QUOTE T)))))
DEFINE EVCON
(LAMBDA (C A)
(COND ((EVAL (CAR (CAR C)) A)
(EVAL (CAR (CDR (CAR C))) A))
((QUOTE T) (EVCON (CDR C) A))))
DEFINE PAIRLIS
(LAMBDA (X Y A)
(COND ((EQ X NIL) A)
((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
(PAIRLIS (CDR X) (CDR Y) A)))))
DEFINE EVLIS
(LAMBDA (M A)
(COND ((EQ M NIL) M)
((QUOTE T) (CONS (EVAL (CAR M) A)
(EVLIS (CDR M) A)))))
DEFINE APPLY
(LAMBDA (FN X A)
(COND
((ATOM FN)
(COND ((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)))))
DEFINE EVAL
(LAMBDA (E A)
(COND
((ATOM E)
(COND ((EQ E NIL) E)
((EQ E (QUOTE T)) (QUOTE T))
((QUOTE T) (ASSOC E A))))
((ATOM (CAR E))
(COND ((EQ (CAR E) (QUOTE QUOTE)) (CAR (CDR E)))
((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
((EQ (CAR E) (QUOTE LAMBDA)) E)
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
(EVAL (QUOTE ((LAMBDA (FF X)
(FF X))
(LAMBDA (X)
(COND ((ATOM X) X)
(T (FF (CAR X)))))
(QUOTE ((A) B C))))
NIL)

116
sectorlisp.S
View file

@ -23,14 +23,13 @@
// Compatible with the original hardware
.code16
.set save,-2-2
.set look,start+5-2
.globl _start
.set a,-2-2
.globl _start # LISP: VERITAS NUMQUAM PERIT
_start: .asciz "NIL" # dec %si ; dec %cx ; dec %sp
kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
start: mov $0x8000,%sp # this should be safe we hope
ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
.asciz ""
kDefine:.asciz "DEFINE"
kQuote: .asciz "QUOTE"
kCond: .asciz "COND"
kAtom: .asciz "ATOM" # ordering matters
@ -39,27 +38,38 @@ kCdr: .asciz "CDR" # ordering matters
kCons: .asciz "CONS" # ordering matters
kEq: .asciz "EQ" # needs to be last
begin: push %cs # that means ss = ds = es = cs
pop %ds # noting ljmp set cs to 0x7c00
push %cs # that's the bios load address
pop %es # therefore NULL points to NUL
push %cs # terminated NIL string above!
pop %ss # errata exists but don't care
Read: call GetToken
call GetObject
ret
Define: call Read
push %ax
call Read
pop %di
call Cons
xchg %ax,%di
xchg %bp,%ax
call Cons
xchg %ax,%bp
jmp main
begin: mov $0x8000,%sp
push %cs
pop %ds
push %cs
pop %es
push %cs
pop %ss
mov $2,%bx
mov %sp,%cx
main: call GetToken
call GetObject
mov %dx,save(%bx)
xor %bp,%bp
main: xor %dx,%dx
call Read
cmp $kDefine,%ax
je Define
mov %bp,%dx
call Eval
test %ax,%ax
jns Print
push %ax
xchg %ax,%di
xchg %dx,%ax
call Cons
xchg %ax,%dx
pop %ax
Print: xchg %ax,%si
Catch: xchg %ax,%si
call PrintObject
mov $'\r',%al
call PutChar
@ -67,26 +77,25 @@ Print: xchg %ax,%si
GetToken: # GetToken():al
mov %cx,%di
1: mov look(%bx),%al
1: mov %dl,%al
cmp $' ',%al
jbe 2f
stosb
xchg %ax,%si
2: call GetChar # exchanges dx and ax
cmp $'\b',%al
jne 4f
dec %di
jmp 2b
4: xchg %ax,look(%bx)
je 4f
cmp $' ',%al
jbe 1b
cmp $')',%al
jbe 3f
cmpb $')',look(%bx)
cmp $')',%dl
ja 1b
3: mov %bh,(%di) # bh is zero
xchg %si,%ax
ret
4: dec %di
jmp 2b
.PrintList:
mov $'(',%al
@ -106,7 +115,7 @@ GetToken: # GetToken():al
.PutObject: # .PutObject(c:al,x:si)
.PrintString: # nul-terminated in si
call PutChar # preserves si
PrintObject: # PrintObject(x:si)
PrintObject: # PrintObject(x:si,a:di)
test %si,%si # set sf=1 if cons
js .PrintList # jump if not cons
.PrintAtom:
@ -121,39 +130,42 @@ GetObject: # called just after GetToken
# jmp Intern
Intern: push %cx # Intern(cx,di): ax
mov %di,%bp
sub %cx,%bp
inc %bp
sub %cx,%di
inc %di
push %di
xor %di,%di
1: pop %si
1: pop %cx
pop %si
push %si
mov %bp,%cx
push %cx
mov %di,%ax
cmp %bh,(%di)
je 2f
je 8f
rep cmpsb # memcmp(di,si,cx)
je 9f
not %cx
xor %ax,%ax
repne scasb # memchr(di,al,cx)
2: scasb
jne 2b
jmp 1b
2: rep movsb # memcpy(di,si,cx)
8: rep movsb # memcpy(di,si,cx)
9: pop %cx
3: ret
pop %cx
ret
Undef: push %ax
mov $'?',%al
call PutChar
pop %ax
mov save(%bx),%dx
jmp Print
jmp Catch
GetChar:xor %ax,%ax # GetChar→al:dl
int $0x16 # get keystroke
PutChar:mov $0x0e,%ah # prints CP-437
push %bp # scroll up bug
int $0x10 # vidya service
pop %bp # scroll up bug
cmp $'\r',%al # don't clobber
jne 3b # look xchg ret
jne 1f # look xchg ret
mov $'\n',%al
jmp PutChar
@ -213,7 +225,12 @@ Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax
mov (%bx,%si),%si
scasw
jne 1b
jmp Car
.byte 0xf6
Cadr: mov (%bx,%di),%di # contents of decrement register
.byte 0x3C # cmp §scasw,%al (nop next byte)
Cdr: scasw # increments our data index by 2
Car: mov (%di),%ax # contents of address register!!
2: ret
GetList:call GetToken
cmp $')',%al
@ -255,17 +272,11 @@ Apply: test %ax,%ax # Apply(fn:ax,x:si:a:dx):ax
mov (%bx,%si),%si # si = Cdr(x)
lodsw # si = Cadr(x)
je Cons
.isEq: cmp %di,%ax # we know for certain it's eq
.isEq: xor %di,%ax # we know for certain it's eq
jne .retF
.retT: mov $kT,%ax
.retT: mov $kT,%al
ret
Cadr: mov (%bx,%di),%di # contents of decrement register
.byte 0x3C # cmp §scasw,%al (nop next byte)
Cdr: scasw # increments our data index by 2
Car: mov (%di),%ax # contents of address register!!
2: ret
1: mov (%bx,%di),%di # di = Cdr(c)
Evcon: push %di # save c
mov (%di),%si # di = Car(c)
@ -309,6 +320,7 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
.sig: .fill 510 - (. - _start), 1, 0xce
.word 0xAA55
.type .sig,@object
.type kDefine,@object
.type kQuote,@object
.type kCond,@object
.type kAtom,@object