mirror of
https://github.com/samsonjs/sectorlisp.git
synced 2026-03-25 09:05:48 +00:00
Make DEFINE more like Scheme
This commit is contained in:
Justine Tunney
parent
a25d58bddd
commit
f6e8f51307
2 changed files with 178 additions and 85 deletions
218
lisp.js
218
lisp.js
|
|
@ -26,19 +26,24 @@ exit
|
|||
#define function
|
||||
#define Null 16384
|
||||
var M[Null * 2];
|
||||
var (*funcall)();
|
||||
jmp_buf undefined;
|
||||
//`
|
||||
|
||||
var cx, dx, lo, kT, kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote, kDefine;
|
||||
|
||||
function Set(i, x) {
|
||||
M[Null + i] = x;
|
||||
}
|
||||
var cx, dx, depth, panic;
|
||||
var cHeap, cGets, cSets, cPrints;
|
||||
var kT, kEq, kCar, kCdr, kCond, kAtom, kCons, kQuote, kDefine;
|
||||
|
||||
function Get(i) {
|
||||
++cGets;
|
||||
return M[Null + i];
|
||||
}
|
||||
|
||||
function Set(i, x) {
|
||||
++cSets;
|
||||
M[Null + i] = x;
|
||||
}
|
||||
|
||||
function Car(x) {
|
||||
if (x > 0) Throw(List(kCar, x));
|
||||
return x ? Get(x) : +0;
|
||||
|
|
@ -52,7 +57,7 @@ function Cdr(x) {
|
|||
function Cons(car, cdr) {
|
||||
Set(--cx, cdr);
|
||||
Set(--cx, car);
|
||||
if (cx < lo) lo = cx;
|
||||
if (cx < cHeap) cHeap = cx;
|
||||
return cx;
|
||||
}
|
||||
|
||||
|
|
@ -77,11 +82,6 @@ function ReadAtom(h) {
|
|||
Hash(h, c) - Hash(0, Ord('N')));
|
||||
}
|
||||
|
||||
function PrintAtom(x) {
|
||||
do PrintChar(Get(x));
|
||||
while ((x = Get(x + 1)));
|
||||
}
|
||||
|
||||
function ReadList() {
|
||||
var x;
|
||||
if ((x = Read()) > 0) {
|
||||
|
|
@ -100,17 +100,33 @@ function ReadObject(t) {
|
|||
return ReadList();
|
||||
}
|
||||
|
||||
function Read() {
|
||||
return ReadObject(ReadAtom(0));
|
||||
}
|
||||
|
||||
function PrintAtom(x) {
|
||||
do PrintChar(Get(x));
|
||||
while ((x = Get(x + 1)));
|
||||
}
|
||||
|
||||
function PrintList(x) {
|
||||
PrintChar(Ord('('));
|
||||
if (x < 0) {
|
||||
PrintObject(Car(x));
|
||||
Print(Car(x));
|
||||
while ((x = Cdr(x))) {
|
||||
if (panic && cPrints > panic) {
|
||||
PrintChar(Ord(' '));
|
||||
PrintChar(0x2026);
|
||||
break;
|
||||
}
|
||||
if (x < 0) {
|
||||
PrintChar(Ord(' '));
|
||||
PrintObject(Car(x));
|
||||
Print(Car(x));
|
||||
} else {
|
||||
PrintChar(0x2219);
|
||||
PrintObject(x);
|
||||
PrintChar(Ord(' '));
|
||||
PrintChar(Ord('.'));
|
||||
PrintChar(Ord(' '));
|
||||
Print(x);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
|
@ -118,7 +134,8 @@ function PrintList(x) {
|
|||
PrintChar(Ord(')'));
|
||||
}
|
||||
|
||||
function PrintObject(x) {
|
||||
function Print(x) {
|
||||
++cPrints;
|
||||
if (1./x < 0) {
|
||||
PrintList(x);
|
||||
} else {
|
||||
|
|
@ -126,13 +143,12 @@ function PrintObject(x) {
|
|||
}
|
||||
}
|
||||
|
||||
function Print(e) {
|
||||
PrintObject(e);
|
||||
PrintChar(Ord('\n'));
|
||||
function List(x, y) {
|
||||
return Cons(x, Cons(y, 0));
|
||||
}
|
||||
|
||||
function Read() {
|
||||
return ReadObject(ReadAtom(0));
|
||||
function Define(A, x, a) {
|
||||
return Gc(A, Cons(x, Remove(Car(x), a)));
|
||||
}
|
||||
|
||||
function Remove(x, y) {
|
||||
|
|
@ -141,14 +157,6 @@ function Remove(x, y) {
|
|||
return Cons(Car(y), Remove(x, Cdr(y)));
|
||||
}
|
||||
|
||||
function List(x, y) {
|
||||
return Cons(x, Cons(y, 0));
|
||||
}
|
||||
|
||||
function Define(x, y) {
|
||||
return Cons(Cons(x, Read()), Remove(x, y));
|
||||
}
|
||||
|
||||
function Gc(A, x) {
|
||||
var C, B = cx;
|
||||
x = Copy(x, A, A - B), C = cx;
|
||||
|
|
@ -167,7 +175,6 @@ function Evlis(m, a) {
|
|||
}
|
||||
|
||||
function Pairlis(x, y, a) {
|
||||
if (!!x ^ !!y) Throw(List(x, y));
|
||||
return x ? Cons(Cons(Car(x), Car(y)),
|
||||
Pairlis(Cdr(x), Cdr(y), a)) : a;
|
||||
}
|
||||
|
|
@ -184,7 +191,7 @@ function Evcon(c, a) {
|
|||
} else if (Cdr(c)) {
|
||||
return Evcon(Cdr(c), a);
|
||||
} else {
|
||||
Throw(c);
|
||||
Throw(Cons(kCond, c));
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -195,16 +202,61 @@ function Apply(f, x, a) {
|
|||
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);
|
||||
return funcall(f, Assoc(f, a), x, a);
|
||||
}
|
||||
|
||||
function Eval(e, a) {
|
||||
var A = cx;
|
||||
if (!e) return e;
|
||||
if (e > 0) return Assoc(e, a);
|
||||
if (Car(e) == kQuote) return Car(Cdr(e));
|
||||
if (Car(e) == kCond) return Gc(A, Evcon(Cdr(e), a));
|
||||
return Gc(A, Apply(Car(e), Evlis(Cdr(e), a), a));
|
||||
if (Car(e) == kCond) return Evcon(Cdr(e), a);
|
||||
return Apply(Car(e), Evlis(Cdr(e), a), a);
|
||||
}
|
||||
|
||||
function Funcall(f, l, x, a) {
|
||||
var A = cx;
|
||||
return Gc(A, Apply(l, x, a));
|
||||
}
|
||||
|
||||
function Funtrace(f, l, x, a) {
|
||||
var y, i, A = cx;
|
||||
Indent(depth);
|
||||
Print(f);
|
||||
Print(x);
|
||||
PrintChar(Ord('\n'));
|
||||
depth += 2;
|
||||
y = Funcall(f, l, x, a);
|
||||
depth -= 2;
|
||||
Indent(depth);
|
||||
Print(f);
|
||||
Print(x);
|
||||
PrintChar(Ord(' '));
|
||||
PrintChar(0x2192);
|
||||
PrintChar(Ord(' '));
|
||||
Print(y);
|
||||
PrintChar(Ord('\n'));
|
||||
return y;
|
||||
}
|
||||
|
||||
function Indent(i) {
|
||||
if (!i) return;
|
||||
PrintChar(Ord(' '));
|
||||
Indent(i - 1);
|
||||
}
|
||||
|
||||
function Dump(a) {
|
||||
if (!a) return;
|
||||
Dump(Cdr(a));
|
||||
PrintChar(Ord('('));
|
||||
Print(kDefine);
|
||||
PrintChar(Ord(' '));
|
||||
Print(Car(Car(a)));
|
||||
PrintChar(Ord(' '));
|
||||
PrintChar(Ord('.'));
|
||||
PrintChar(Ord(' '));
|
||||
Print(Cdr(Car(a)));
|
||||
PrintChar(Ord(')'));
|
||||
PrintChar(Ord('\n'));
|
||||
}
|
||||
|
||||
function LoadBuiltins() {
|
||||
|
|
@ -267,17 +319,24 @@ ReadChar() {
|
|||
}
|
||||
}
|
||||
|
||||
main() {
|
||||
main(argc, argv)
|
||||
char *argv[];
|
||||
{
|
||||
var x, a, A;
|
||||
setlocale(LC_ALL, "");
|
||||
bestlineSetXlatCallback(bestlineUppercase);
|
||||
if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 't') {
|
||||
funcall = Funtrace;
|
||||
} else {
|
||||
funcall = Funcall;
|
||||
}
|
||||
LoadBuiltins();
|
||||
for (a = 0;;) {
|
||||
A = cx;
|
||||
if (!(x = setjmp(undefined))) {
|
||||
x = Read();
|
||||
if (x == kDefine) {
|
||||
a = Gc(0, Define(Read(), a));
|
||||
if (x < 0 && Car(x) == kDefine) {
|
||||
a = Define(0, Cdr(x), a);
|
||||
SaveMachine(a);
|
||||
continue;
|
||||
}
|
||||
|
|
@ -287,6 +346,7 @@ main() {
|
|||
PrintChar('?');
|
||||
}
|
||||
Print(x);
|
||||
PrintChar('\n');
|
||||
Gc(A, 0);
|
||||
}
|
||||
}
|
||||
|
|
@ -296,8 +356,8 @@ main() {
|
|||
////////////////////////////////////////////////////////////////////////////////
|
||||
// JavaScript Specific Code for https://justine.lol/
|
||||
|
||||
var a, code, index, output, M, Null;
|
||||
var eInput, eOutput, eSubmit, eReset, eLoad, ePrograms;
|
||||
var a, code, index, output, funcall, M, Null;
|
||||
var eInput, eOutput, eEval, eReset, eLoad, eTrace, ePrograms;
|
||||
|
||||
function Throw(x) {
|
||||
throw x;
|
||||
|
|
@ -311,7 +371,10 @@ function Reset() {
|
|||
var i;
|
||||
a = 0;
|
||||
cx = 0;
|
||||
lo = 0;
|
||||
cHeap = 0;
|
||||
cGets = 0;
|
||||
cSets = 0;
|
||||
cPrints = 0;
|
||||
Null = 16384;
|
||||
M = new Array(Null * 2);
|
||||
for (i = 0; i < M.length; ++i) {
|
||||
|
|
@ -343,8 +406,11 @@ function ReadChar() {
|
|||
|
||||
function Lisp() {
|
||||
var x, A;
|
||||
lo = cx;
|
||||
output = '';
|
||||
cGets = 0;
|
||||
cSets = 0;
|
||||
cHeap = cx;
|
||||
cPrints = 0;
|
||||
output = "";
|
||||
while (dx) {
|
||||
if (dx <= Ord(' ')) {
|
||||
ReadChar();
|
||||
|
|
@ -352,8 +418,8 @@ function Lisp() {
|
|||
A = cx;
|
||||
try {
|
||||
x = Read();
|
||||
if (x == kDefine) {
|
||||
a = Gc(0, Define(Read(), a));
|
||||
if (x < 0 && Car(x) == kDefine) {
|
||||
a = Define(0, Cdr(x), a);
|
||||
continue;
|
||||
}
|
||||
x = Eval(x, a);
|
||||
|
|
@ -362,6 +428,7 @@ function Lisp() {
|
|||
x = z;
|
||||
}
|
||||
Print(x);
|
||||
PrintChar(Ord('\n'));
|
||||
Gc(A, 0);
|
||||
}
|
||||
}
|
||||
|
|
@ -377,21 +444,11 @@ function Load(s) {
|
|||
index = 1;
|
||||
}
|
||||
|
||||
function OnSubmit() {
|
||||
function OnEval() {
|
||||
Load(eInput.value.toUpperCase());
|
||||
Lisp();
|
||||
}
|
||||
|
||||
function Dump(a) {
|
||||
if (!a) return;
|
||||
Dump(Cdr(a));
|
||||
output += "DEFINE ";
|
||||
PrintObject(Car(Car(a)));
|
||||
output += " ";
|
||||
PrintObject(Cdr(Car(a)));
|
||||
output += "\n";
|
||||
}
|
||||
|
||||
function OnReset() {
|
||||
output = "";
|
||||
try {
|
||||
|
|
@ -406,6 +463,18 @@ function OnReset() {
|
|||
ReportUsage();
|
||||
}
|
||||
|
||||
function OnTrace() {
|
||||
var t;
|
||||
Load(eInput.value);
|
||||
t = panic;
|
||||
depth = 0;
|
||||
panic = 10000;
|
||||
funcall = Funtrace;
|
||||
Lisp();
|
||||
funcall = Funcall;
|
||||
panic = t;
|
||||
}
|
||||
|
||||
function OnLoad() {
|
||||
ePrograms.classList.toggle("show");
|
||||
}
|
||||
|
|
@ -431,7 +500,7 @@ function RestoreMachine() {
|
|||
M = machine[0];
|
||||
a = machine[1];
|
||||
cx = machine[2];
|
||||
lo = cx;
|
||||
cHeap = cx;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -449,25 +518,48 @@ function Number(i) {
|
|||
function ReportUsage() {
|
||||
var i, c;
|
||||
for (c = i = 0; i < Null; i += 2) {
|
||||
if (Get(i)) ++c;
|
||||
if (M[Null + i]) ++c;
|
||||
}
|
||||
document.getElementById("usage").innerText =
|
||||
document.getElementById("ops").innerText =
|
||||
Number(cGets) + " gets / " +
|
||||
Number(cSets) + " sets";
|
||||
document.getElementById("mem").innerText =
|
||||
Number((-cx >> 1) + c) + " / " +
|
||||
Number((-lo >> 1) + c) + " / " +
|
||||
Number((-cHeap >> 1) + c) + " / " +
|
||||
Number(Null) + " doublewords";
|
||||
}
|
||||
|
||||
function Discount(f) {
|
||||
return function() {
|
||||
var x, g, h, s;
|
||||
g = cGets;
|
||||
s = cSets;
|
||||
h = cHeap;
|
||||
x = f.apply(this, arguments);
|
||||
cHeap = h;
|
||||
cSets = s;
|
||||
cGets = g;
|
||||
return x;
|
||||
};
|
||||
}
|
||||
|
||||
function SetUp() {
|
||||
funcall = Funcall;
|
||||
Read = Discount(Read);
|
||||
Print = Discount(Print);
|
||||
Define = Discount(Define);
|
||||
eLoad = document.getElementById("load");
|
||||
eInput = document.getElementById("input");
|
||||
eReset = document.getElementById("reset");
|
||||
eTrace = document.getElementById("trace");
|
||||
eOutput = document.getElementById("output");
|
||||
eSubmit = document.getElementById("submit");
|
||||
eEval = document.getElementById("eval");
|
||||
ePrograms = document.getElementById("programs");
|
||||
window.onclick = OnWindowClick;
|
||||
eSubmit.onclick = OnSubmit;
|
||||
eReset.onclick = OnReset;
|
||||
eLoad.onclick = OnLoad;
|
||||
eReset.onclick = OnReset;
|
||||
eTrace.onclick = OnTrace;
|
||||
eEval.onclick = OnEval;
|
||||
Reset();
|
||||
RestoreMachine();
|
||||
ReportUsage();
|
||||
|
|
|
|||
45
sectorlisp.S
45
sectorlisp.S
|
|
@ -34,8 +34,8 @@ kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
|
|||
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
|
||||
.asciz ""
|
||||
kDefine:.asciz "DEFINE"
|
||||
kQuote: .asciz "QUOTE"
|
||||
kCond: .asciz "COND"
|
||||
kQuote: .asciz "QUOTE"
|
||||
kCar: .asciz "CAR" # ordering matters
|
||||
kCdr: .asciz "CDR" # ordering matters
|
||||
kCons: .asciz "CONS" # ordering matters
|
||||
|
|
@ -123,16 +123,14 @@ PutChar:mov $0x0e,%ah # prints CP-437
|
|||
int $0x10 # vidya service
|
||||
pop %bp # scroll up bug
|
||||
cmp $'\r',%al # don't clobber
|
||||
jne .RetDx # look xchg ret
|
||||
jne .retDx # look xchg ret
|
||||
mov $'\n',%al
|
||||
jmp PutChar
|
||||
.RetDx: xchg %dx,%ax
|
||||
ret
|
||||
|
||||
////////////////////////////////////////////////////////////////////////////////
|
||||
|
||||
Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax
|
||||
jb .RetDi # we assume immutable cells
|
||||
jb .retDi # we assume immutable cells
|
||||
push (%bx,%di) # mark prevents negative gc
|
||||
mov (%di),%di
|
||||
call Gc
|
||||
|
|
@ -146,7 +144,7 @@ Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax
|
|||
ret
|
||||
|
||||
Evlis: test %di,%di # Evlis(m:di,a:dx):ax
|
||||
jz .RetDi # jump if nil
|
||||
jz .retDi # jump if nil
|
||||
push (%bx,%di) # save 1 Cdr(m)
|
||||
mov (%di),%ax
|
||||
call Eval
|
||||
|
|
@ -160,7 +158,7 @@ Cons: xchg %di,%cx # Cons(m:di,a:ax):ax
|
|||
mov %cx,(%di) # must preserve si
|
||||
mov %ax,(%bx,%di)
|
||||
lea 4(%di),%cx
|
||||
.RetDi: xchg %di,%ax
|
||||
.retDi: xchg %di,%ax
|
||||
ret
|
||||
|
||||
GetList:call GetToken
|
||||
|
|
@ -178,6 +176,9 @@ GetList:call GetToken
|
|||
pop %ax
|
||||
ret
|
||||
|
||||
.retDx: xchg %dx,%ax
|
||||
ret
|
||||
|
||||
.resolv:push %si
|
||||
call Eval # do (fn si) → ((λ ...) si)
|
||||
pop %si
|
||||
|
|
@ -189,11 +190,16 @@ Apply: test %ax,%ax # Apply(fn:ax,x:si:a:dx):ax
|
|||
mov (%di),%di # di = Cadr(fn)
|
||||
Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):dx
|
||||
jz .EvCadr # return if x is nil
|
||||
xor %ax,%ax # FRIENDLY FEATURE
|
||||
test %si,%si # DEFAULT NIL ARGS
|
||||
jz 1f
|
||||
lodsw # ax = Car(y)
|
||||
push (%bx,%di) # push Cdr(x)
|
||||
1: push (%bx,%di) # push Cdr(x)
|
||||
mov (%di),%di # di = Car(x)
|
||||
test %si,%si
|
||||
jz 1f
|
||||
mov (%si),%si # si = Cdr(y)
|
||||
call Cons # Cons(Car(x),Car(y))
|
||||
1: call Cons # Cons(Car(x),Car(y))
|
||||
xchg %ax,%di
|
||||
xchg %dx,%ax
|
||||
call Cons # Cons(Cons(Car(x),Car(y)),a)
|
||||
|
|
@ -223,6 +229,10 @@ Pairlis:test %di,%di # Pairlis(x:di,y:si,a:dx):dx
|
|||
.retF: xor %ax,%ax # ax = nil
|
||||
ret
|
||||
|
||||
Define: xchg %dx,%ax
|
||||
call Cons
|
||||
jmp .retDx
|
||||
|
||||
Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax
|
||||
1: test %si,%si # FRIENDLY FEATURE
|
||||
jns Undef # PRINT ?X IF X∉DX
|
||||
|
|
@ -260,6 +270,7 @@ Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
|
|||
je Car
|
||||
cmp $kCond,%ax
|
||||
je Evcon # ABC Garbage Collector
|
||||
jb Define
|
||||
push %dx # save a
|
||||
push %cx # save A
|
||||
push %ax
|
||||
|
|
@ -288,17 +299,6 @@ Read: call GetToken
|
|||
call GetObject
|
||||
ret
|
||||
|
||||
Define: call Read # FRIENDLY FEATURE
|
||||
push %ax # DEFINE NAME SEXP
|
||||
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
|
||||
|
|
@ -311,10 +311,11 @@ begin: mov $0x8000,%sp
|
|||
xor %bp,%bp
|
||||
main: xor %dx,%dx
|
||||
call Read
|
||||
cmp $kDefine,%ax
|
||||
je Define
|
||||
mov %bp,%dx
|
||||
call Eval
|
||||
mov %dx,%bp
|
||||
cmp $kDefine,%ax
|
||||
je main
|
||||
Catch: xchg %ax,%si
|
||||
call PrintObject
|
||||
mov $'\r',%al
|
||||
|
|
|
|||
Loading…
Reference in a new issue