mirror of
https://github.com/samsonjs/sectorlisp.git
synced 2026-04-27 14:57:41 +00:00
Update code
This commit is contained in:
Justine Tunney
parent
0f6b147099
commit
14873babc7
4 changed files with 126 additions and 386 deletions
5
Makefile
5
Makefile
|
|
@ -17,7 +17,7 @@ all: lisp \
|
||||||
clean:; $(RM) lisp lisp.o bestline.o sectorlisp.o sectorlisp.bin sectorlisp.bin.dbg
|
clean:; $(RM) lisp lisp.o bestline.o sectorlisp.o sectorlisp.bin sectorlisp.bin.dbg
|
||||||
|
|
||||||
lisp: lisp.o bestline.o
|
lisp: lisp.o bestline.o
|
||||||
lisp.o: lisp.c bestline.h
|
lisp.o: lisp.js bestline.h
|
||||||
bestline.o: bestline.c bestline.h
|
bestline.o: bestline.c bestline.h
|
||||||
|
|
||||||
sectorlisp.o: sectorlisp.S
|
sectorlisp.o: sectorlisp.S
|
||||||
|
|
@ -28,3 +28,6 @@ sectorlisp.bin.dbg: sectorlisp.o
|
||||||
|
|
||||||
sectorlisp.bin: sectorlisp.bin.dbg
|
sectorlisp.bin: sectorlisp.bin.dbg
|
||||||
objcopy -S -O binary sectorlisp.bin.dbg sectorlisp.bin
|
objcopy -S -O binary sectorlisp.bin.dbg sectorlisp.bin
|
||||||
|
|
||||||
|
%.o: %.js
|
||||||
|
$(COMPILE.c) -xc $(OUTPUT_OPTION) $<
|
||||||
|
|
|
||||||
274
lisp.c
274
lisp.c
|
|
@ -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();
|
|
||||||
}
|
|
||||||
63
lisp.lisp
63
lisp.lisp
|
|
@ -69,38 +69,39 @@ NIL
|
||||||
(QUOTE ((A) B C)))
|
(QUOTE ((A) B C)))
|
||||||
|
|
||||||
;; LISP IMPLEMENTED IN LISP
|
;; LISP IMPLEMENTED IN LISP
|
||||||
;; WITHOUT ANY SUBJECTIVE SYNTACTIC SUGAR
|
|
||||||
;; RUNS "FIND FIRST ATOM IN TREE" PROGRAM
|
;; RUNS "FIND FIRST ATOM IN TREE" PROGRAM
|
||||||
;; CORRECT RESULT OF EXPRESSION IS STILL `A`
|
;; CORRECT RESULT OF EXPRESSION IS STILL `A`
|
||||||
;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND
|
;; REQUIRES CONS CAR CDR QUOTE ATOM EQ LAMBDA COND
|
||||||
;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER
|
;; SIMPLIFIED BUG FIXED VERSION OF JOHN MCCARTHY PAPER
|
||||||
;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP
|
;; NOTE: ((EQ (CAR E) ()) (QUOTE *UNDEFINED)) CAN HELP
|
||||||
;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE
|
;; NOTE: ((EQ (CAR E) (QUOTE LAMBDA)) E) IS NICE
|
||||||
((LAMBDA (ASSOC EVCON PAIRLIS EVLIS APPLY EVAL)
|
|
||||||
(EVAL (QUOTE ((LAMBDA (FF X)
|
DEFINE ASSOC
|
||||||
(FF X))
|
(LAMBDA (X Y)
|
||||||
(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))
|
(COND ((EQ Y NIL) (QUOTE *UNDEFINED))
|
||||||
((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
|
((EQ X (CAR (CAR Y))) (CDR (CAR Y)))
|
||||||
((QUOTE T) (ASSOC X (CDR Y))))))
|
((QUOTE T) (ASSOC X (CDR Y)))))
|
||||||
(QUOTE (LAMBDA (C A)
|
|
||||||
|
DEFINE EVCON
|
||||||
|
(LAMBDA (C A)
|
||||||
(COND ((EVAL (CAR (CAR C)) A)
|
(COND ((EVAL (CAR (CAR C)) A)
|
||||||
(EVAL (CAR (CDR (CAR C))) A))
|
(EVAL (CAR (CDR (CAR C))) A))
|
||||||
((QUOTE T) (EVCON (CDR C) A)))))
|
((QUOTE T) (EVCON (CDR C) A))))
|
||||||
(QUOTE (LAMBDA (X Y A)
|
|
||||||
|
DEFINE PAIRLIS
|
||||||
|
(LAMBDA (X Y A)
|
||||||
(COND ((EQ X NIL) A)
|
(COND ((EQ X NIL) A)
|
||||||
((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
|
((QUOTE T) (CONS (CONS (CAR X) (CAR Y))
|
||||||
(PAIRLIS (CDR X) (CDR Y) A))))))
|
(PAIRLIS (CDR X) (CDR Y) A)))))
|
||||||
(QUOTE (LAMBDA (M A)
|
|
||||||
|
DEFINE EVLIS
|
||||||
|
(LAMBDA (M A)
|
||||||
(COND ((EQ M NIL) M)
|
(COND ((EQ M NIL) M)
|
||||||
((QUOTE T) (CONS (EVAL (CAR M) A)
|
((QUOTE T) (CONS (EVAL (CAR M) A)
|
||||||
(EVLIS (CDR M) A))))))
|
(EVLIS (CDR M) A)))))
|
||||||
(QUOTE (LAMBDA (FN X A)
|
|
||||||
|
DEFINE APPLY
|
||||||
|
(LAMBDA (FN X A)
|
||||||
(COND
|
(COND
|
||||||
((ATOM FN)
|
((ATOM FN)
|
||||||
(COND ((EQ FN (QUOTE CAR)) (CAR (CAR X)))
|
(COND ((EQ FN (QUOTE CAR)) (CAR (CAR X)))
|
||||||
|
|
@ -111,8 +112,10 @@ NIL
|
||||||
((QUOTE T) (APPLY (EVAL FN A) X A))))
|
((QUOTE T) (APPLY (EVAL FN A) X A))))
|
||||||
((EQ (CAR FN) (QUOTE LAMBDA))
|
((EQ (CAR FN) (QUOTE LAMBDA))
|
||||||
(EVAL (CAR (CDR (CDR FN)))
|
(EVAL (CAR (CDR (CDR FN)))
|
||||||
(PAIRLIS (CAR (CDR FN)) X A))))))
|
(PAIRLIS (CAR (CDR FN)) X A)))))
|
||||||
(QUOTE (LAMBDA (E A)
|
|
||||||
|
DEFINE EVAL
|
||||||
|
(LAMBDA (E A)
|
||||||
(COND
|
(COND
|
||||||
((ATOM E)
|
((ATOM E)
|
||||||
(COND ((EQ E NIL) E)
|
(COND ((EQ E NIL) E)
|
||||||
|
|
@ -123,16 +126,12 @@ NIL
|
||||||
((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
|
((EQ (CAR E) (QUOTE COND)) (EVCON (CDR E) A))
|
||||||
((EQ (CAR E) (QUOTE LAMBDA)) E)
|
((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))))
|
||||||
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))))
|
((QUOTE T) (APPLY (CAR E) (EVLIS (CDR E) A) A))))
|
||||||
|
|
||||||
(CONS (QUOTE NOT)
|
(EVAL (QUOTE ((LAMBDA (FF X)
|
||||||
(QUOTE (LAMBDA (X)
|
(FF X))
|
||||||
(COND (X (QUOTE F))
|
(LAMBDA (X)
|
||||||
((QUOTE T) (QUOTE T))))))
|
(COND ((ATOM X) X)
|
||||||
|
(T (FF (CAR X)))))
|
||||||
((LAMBDA (X E C)
|
(QUOTE ((A) B C))))
|
||||||
(CONS (QUOTE LAMBDA) (CONS NIL (CONS (CAR (CDR C)) NIL))))
|
NIL)
|
||||||
(QUOTE T)
|
|
||||||
(QUOTE (LAMBDA (F) (F)))
|
|
||||||
(QUOTE (COND (X (QUOTE F))
|
|
||||||
((QUOTE T) (QUOTE T)))))
|
|
||||||
|
|
|
||||||
116
sectorlisp.S
116
sectorlisp.S
|
|
@ -23,14 +23,13 @@
|
||||||
// Compatible with the original hardware
|
// Compatible with the original hardware
|
||||||
|
|
||||||
.code16
|
.code16
|
||||||
.set save,-2-2
|
.set a,-2-2
|
||||||
.set look,start+5-2
|
.globl _start # LISP: VERITAS NUMQUAM PERIT
|
||||||
.globl _start
|
|
||||||
_start: .asciz "NIL" # dec %si ; dec %cx ; dec %sp
|
_start: .asciz "NIL" # dec %si ; dec %cx ; dec %sp
|
||||||
kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
|
kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
|
||||||
start: mov $0x8000,%sp # this should be safe we hope
|
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
|
||||||
ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
|
|
||||||
.asciz ""
|
.asciz ""
|
||||||
|
kDefine:.asciz "DEFINE"
|
||||||
kQuote: .asciz "QUOTE"
|
kQuote: .asciz "QUOTE"
|
||||||
kCond: .asciz "COND"
|
kCond: .asciz "COND"
|
||||||
kAtom: .asciz "ATOM" # ordering matters
|
kAtom: .asciz "ATOM" # ordering matters
|
||||||
|
|
@ -39,27 +38,38 @@ kCdr: .asciz "CDR" # ordering matters
|
||||||
kCons: .asciz "CONS" # ordering matters
|
kCons: .asciz "CONS" # ordering matters
|
||||||
kEq: .asciz "EQ" # needs to be last
|
kEq: .asciz "EQ" # needs to be last
|
||||||
|
|
||||||
begin: push %cs # that means ss = ds = es = cs
|
Read: call GetToken
|
||||||
pop %ds # noting ljmp set cs to 0x7c00
|
call GetObject
|
||||||
push %cs # that's the bios load address
|
ret
|
||||||
pop %es # therefore NULL points to NUL
|
|
||||||
push %cs # terminated NIL string above!
|
Define: call Read
|
||||||
pop %ss # errata exists but don't care
|
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 $2,%bx
|
||||||
mov %sp,%cx
|
mov %sp,%cx
|
||||||
main: call GetToken
|
xor %bp,%bp
|
||||||
call GetObject
|
main: xor %dx,%dx
|
||||||
mov %dx,save(%bx)
|
call Read
|
||||||
|
cmp $kDefine,%ax
|
||||||
|
je Define
|
||||||
|
mov %bp,%dx
|
||||||
call Eval
|
call Eval
|
||||||
test %ax,%ax
|
Catch: xchg %ax,%si
|
||||||
jns Print
|
|
||||||
push %ax
|
|
||||||
xchg %ax,%di
|
|
||||||
xchg %dx,%ax
|
|
||||||
call Cons
|
|
||||||
xchg %ax,%dx
|
|
||||||
pop %ax
|
|
||||||
Print: xchg %ax,%si
|
|
||||||
call PrintObject
|
call PrintObject
|
||||||
mov $'\r',%al
|
mov $'\r',%al
|
||||||
call PutChar
|
call PutChar
|
||||||
|
|
@ -67,26 +77,25 @@ Print: xchg %ax,%si
|
||||||
|
|
||||||
GetToken: # GetToken():al
|
GetToken: # GetToken():al
|
||||||
mov %cx,%di
|
mov %cx,%di
|
||||||
1: mov look(%bx),%al
|
1: mov %dl,%al
|
||||||
cmp $' ',%al
|
cmp $' ',%al
|
||||||
jbe 2f
|
jbe 2f
|
||||||
stosb
|
stosb
|
||||||
xchg %ax,%si
|
xchg %ax,%si
|
||||||
2: call GetChar # exchanges dx and ax
|
2: call GetChar # exchanges dx and ax
|
||||||
cmp $'\b',%al
|
cmp $'\b',%al
|
||||||
jne 4f
|
je 4f
|
||||||
dec %di
|
|
||||||
jmp 2b
|
|
||||||
4: xchg %ax,look(%bx)
|
|
||||||
cmp $' ',%al
|
cmp $' ',%al
|
||||||
jbe 1b
|
jbe 1b
|
||||||
cmp $')',%al
|
cmp $')',%al
|
||||||
jbe 3f
|
jbe 3f
|
||||||
cmpb $')',look(%bx)
|
cmp $')',%dl
|
||||||
ja 1b
|
ja 1b
|
||||||
3: mov %bh,(%di) # bh is zero
|
3: mov %bh,(%di) # bh is zero
|
||||||
xchg %si,%ax
|
xchg %si,%ax
|
||||||
ret
|
ret
|
||||||
|
4: dec %di
|
||||||
|
jmp 2b
|
||||||
|
|
||||||
.PrintList:
|
.PrintList:
|
||||||
mov $'(',%al
|
mov $'(',%al
|
||||||
|
|
@ -106,7 +115,7 @@ GetToken: # GetToken():al
|
||||||
.PutObject: # .PutObject(c:al,x:si)
|
.PutObject: # .PutObject(c:al,x:si)
|
||||||
.PrintString: # nul-terminated in si
|
.PrintString: # nul-terminated in si
|
||||||
call PutChar # preserves si
|
call PutChar # preserves si
|
||||||
PrintObject: # PrintObject(x:si)
|
PrintObject: # PrintObject(x:si,a:di)
|
||||||
test %si,%si # set sf=1 if cons
|
test %si,%si # set sf=1 if cons
|
||||||
js .PrintList # jump if not cons
|
js .PrintList # jump if not cons
|
||||||
.PrintAtom:
|
.PrintAtom:
|
||||||
|
|
@ -121,39 +130,42 @@ GetObject: # called just after GetToken
|
||||||
# jmp Intern
|
# jmp Intern
|
||||||
|
|
||||||
Intern: push %cx # Intern(cx,di): ax
|
Intern: push %cx # Intern(cx,di): ax
|
||||||
mov %di,%bp
|
sub %cx,%di
|
||||||
sub %cx,%bp
|
inc %di
|
||||||
inc %bp
|
push %di
|
||||||
xor %di,%di
|
xor %di,%di
|
||||||
1: pop %si
|
1: pop %cx
|
||||||
|
pop %si
|
||||||
push %si
|
push %si
|
||||||
mov %bp,%cx
|
push %cx
|
||||||
mov %di,%ax
|
mov %di,%ax
|
||||||
cmp %bh,(%di)
|
cmp %bh,(%di)
|
||||||
je 2f
|
je 8f
|
||||||
rep cmpsb # memcmp(di,si,cx)
|
rep cmpsb # memcmp(di,si,cx)
|
||||||
je 9f
|
je 9f
|
||||||
not %cx
|
|
||||||
xor %ax,%ax
|
xor %ax,%ax
|
||||||
repne scasb # memchr(di,al,cx)
|
2: scasb
|
||||||
|
jne 2b
|
||||||
jmp 1b
|
jmp 1b
|
||||||
2: rep movsb # memcpy(di,si,cx)
|
8: rep movsb # memcpy(di,si,cx)
|
||||||
9: pop %cx
|
9: pop %cx
|
||||||
3: ret
|
pop %cx
|
||||||
|
ret
|
||||||
|
|
||||||
Undef: push %ax
|
Undef: push %ax
|
||||||
mov $'?',%al
|
mov $'?',%al
|
||||||
call PutChar
|
call PutChar
|
||||||
pop %ax
|
pop %ax
|
||||||
mov save(%bx),%dx
|
jmp Catch
|
||||||
jmp Print
|
|
||||||
|
|
||||||
GetChar:xor %ax,%ax # GetChar→al:dl
|
GetChar:xor %ax,%ax # GetChar→al:dl
|
||||||
int $0x16 # get keystroke
|
int $0x16 # get keystroke
|
||||||
PutChar:mov $0x0e,%ah # prints CP-437
|
PutChar:mov $0x0e,%ah # prints CP-437
|
||||||
|
push %bp # scroll up bug
|
||||||
int $0x10 # vidya service
|
int $0x10 # vidya service
|
||||||
|
pop %bp # scroll up bug
|
||||||
cmp $'\r',%al # don't clobber
|
cmp $'\r',%al # don't clobber
|
||||||
jne 3b # look xchg ret
|
jne 1f # look xchg ret
|
||||||
mov $'\n',%al
|
mov $'\n',%al
|
||||||
jmp PutChar
|
jmp PutChar
|
||||||
|
|
||||||
|
|
@ -213,7 +225,12 @@ Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax
|
||||||
mov (%bx,%si),%si
|
mov (%bx,%si),%si
|
||||||
scasw
|
scasw
|
||||||
jne 1b
|
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
|
GetList:call GetToken
|
||||||
cmp $')',%al
|
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)
|
mov (%bx,%si),%si # si = Cdr(x)
|
||||||
lodsw # si = Cadr(x)
|
lodsw # si = Cadr(x)
|
||||||
je Cons
|
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
|
jne .retF
|
||||||
.retT: mov $kT,%ax
|
.retT: mov $kT,%al
|
||||||
ret
|
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)
|
1: mov (%bx,%di),%di # di = Cdr(c)
|
||||||
Evcon: push %di # save c
|
Evcon: push %di # save c
|
||||||
mov (%di),%si # di = Car(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
|
.sig: .fill 510 - (. - _start), 1, 0xce
|
||||||
.word 0xAA55
|
.word 0xAA55
|
||||||
.type .sig,@object
|
.type .sig,@object
|
||||||
|
.type kDefine,@object
|
||||||
.type kQuote,@object
|
.type kQuote,@object
|
||||||
.type kCond,@object
|
.type kCond,@object
|
||||||
.type kAtom,@object
|
.type kAtom,@object
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue