mirror of
https://github.com/samsonjs/sectorlisp.git
synced 2026-03-25 09:05:48 +00:00
294 lines
8 KiB
ArmAsm
294 lines
8 KiB
ArmAsm
/*-*- mode:unix-assembly; indent-tabs-mode:t; tab-width:8; coding:utf-8 -*-│
|
|
│vi: set et ft=asm ts=8 tw=8 fenc=utf-8 :vi│
|
|
╞══════════════════════════════════════════════════════════════════════════════╡
|
|
│ Copyright 2020 Justine Alexandra Roberts Tunney │
|
|
│ Copyright 2021 Alain Greppin │
|
|
│ Some size optimisations by Peter Ferrie │
|
|
│ │
|
|
│ 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. │
|
|
╚─────────────────────────────────────────────────────────────────────────────*/
|
|
|
|
// LISP meta-circular evaluator in a MBR
|
|
// Compatible with the original hardware
|
|
|
|
.code16
|
|
.globl _start
|
|
_start: .asciz "NIL" # dec %si ; dec %cx ; dec %sp
|
|
kT: .asciz "T" # add %dl,(%si) boot A:\ DL=0
|
|
start: ljmp $0x7c00>>4,$begin # cs = 0x7c00 is boot address
|
|
.asciz "" # interned strings
|
|
kQuote: .asciz "QUOTE" # builtin for eval
|
|
kCond: .asciz "COND" # builtin for eval
|
|
kCar: .asciz "CAR" # builtin to apply
|
|
kCdr: .asciz "CDR" # ordering matters
|
|
kCons: .asciz "CONS" # must be 3rd last
|
|
kEq: .asciz "EQ" # must be 2nd last
|
|
kAtom: .asciz "ATOM" # needs to be last
|
|
|
|
begin: mov $0x8000,%sp # uses higher address as stack
|
|
# and set independently of SS!
|
|
# 8088 doesn't stop interrupts
|
|
# after SS is set, and PC BIOS
|
|
# sets SP to a value that will
|
|
# damage our code if int fires
|
|
# between it setting SS and SP
|
|
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
|
|
mov $2,%bx
|
|
main: mov %sp,%cx
|
|
mov $'\r',%al
|
|
call PutChar # Call first to initialize %dx
|
|
call GetToken
|
|
call GetObject
|
|
call Eval
|
|
xchg %ax,%si
|
|
call PrintObject
|
|
jmp main
|
|
|
|
GetToken: # GetToken():al, dl is g_look
|
|
mov %cx,%di
|
|
1: mov %dl,%al
|
|
cmp $' ',%al
|
|
jbe 2f
|
|
stosb
|
|
xchg %ax,%si
|
|
2: call GetChar # exchanges dx and ax
|
|
cmp $' ',%al
|
|
jbe 1b
|
|
cmp $')',%al
|
|
jbe 3f
|
|
cmp $')',%dl # dl = g_look
|
|
ja 1b
|
|
3: mov %bh,(%di) # bh is zero
|
|
xchg %si,%ax
|
|
ret
|
|
|
|
.PrintList:
|
|
mov $'(',%al
|
|
2: push (%bx,%si)
|
|
mov (%si),%si
|
|
call .PutObject
|
|
mov $' ',%al
|
|
pop %si # restore 1
|
|
test %si,%si
|
|
js 2b # jump if cons
|
|
jz 4f # jump if nil
|
|
mov $249,%al # bullet (A∙B)
|
|
call .PutObject
|
|
4: mov $')',%al
|
|
jmp PutChar
|
|
|
|
.PutObject: # .PutObject(c:al,x:si)
|
|
.PrintString: # nul-terminated in si
|
|
call PutChar # preserves si
|
|
PrintObject: # PrintObject(x:si)
|
|
test %si,%si # set sf=1 if cons
|
|
js .PrintList # jump if not cons
|
|
.PrintAtom:
|
|
lodsb
|
|
test %al,%al # test for nul terminator
|
|
jnz .PrintString # -> ret
|
|
ret
|
|
|
|
GetObject: # called just after GetToken
|
|
cmp $'(',%al
|
|
je GetList
|
|
# jmp Intern
|
|
|
|
Intern: push %cx # Intern(cx,di): ax
|
|
mov %di,%bp
|
|
sub %cx,%bp
|
|
inc %bp
|
|
xor %di,%di
|
|
1: pop %si
|
|
push %si
|
|
mov %bp,%cx
|
|
mov %di,%ax
|
|
cmp %bh,(%di)
|
|
je 8f
|
|
rep cmpsb # memcmp(di,si,cx)
|
|
je 9f
|
|
dec %di
|
|
xor %ax,%ax
|
|
2: scasb # rawmemchr(di,al)
|
|
jne 2b
|
|
jmp 1b
|
|
8: rep movsb # memcpy(di,si,cx)
|
|
9: pop %cx
|
|
ret
|
|
|
|
GetChar:xor %ax,%ax # GetChar→al:dl
|
|
int $0x16 # get keystroke
|
|
PutChar:mov $0x0e,%ah # prints CP-437
|
|
int $0x10 # vidya service
|
|
cmp $'\r',%al # don't clobber
|
|
jne .RetDx # look xchg ret
|
|
mov $'\n',%al
|
|
jmp PutChar
|
|
.RetDx: xchg %dx,%ax
|
|
ret
|
|
|
|
////////////////////////////////////////////////////////////////////////////////
|
|
|
|
Evlis: test %di,%di # Evlis(m:di,a:dx):ax
|
|
jz .RetDi # jump if nil
|
|
push (%bx,%di) # save 1 Cdr(m)
|
|
mov (%di),%ax
|
|
call Eval
|
|
pop %di # restore 1
|
|
push %ax # save 2
|
|
call Evlis
|
|
# jmp xCons
|
|
|
|
xCons: pop %di # restore 2
|
|
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
|
|
ret
|
|
|
|
GetList:call GetToken
|
|
cmp $')',%al
|
|
je .retF
|
|
call GetObject
|
|
push %ax # popped by xCons
|
|
call GetList
|
|
jmp xCons
|
|
|
|
Gc: cmp %dx,%di # Gc(x:di,A:dx,B:si):ax
|
|
jb .RetDi # we assume immutable cells
|
|
push (%bx,%di) # mark prevents negative gc
|
|
mov (%di),%di
|
|
call Gc
|
|
pop %di
|
|
push %ax
|
|
call Gc
|
|
pop %di
|
|
call Cons
|
|
sub %si,%ax
|
|
add %dx,%ax
|
|
ret
|
|
|
|
.resolv:push %si
|
|
call Assoc # do (fn si) → ((λ ...) si)
|
|
pop %si
|
|
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 # for .EvCadr
|
|
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
|
|
lodsw # ax = Car(y)
|
|
push (%bx,%di) # push Cdr(x)
|
|
mov (%di),%di # di = Car(x)
|
|
mov (%si),%si # si = Cdr(y)
|
|
call Cons # Cons(Car(x),Car(y))
|
|
xchg %ax,%di
|
|
xchg %dx,%ax
|
|
call Cons # Cons(Cons(Car(x),Car(y)),a)
|
|
xchg %ax,%dx # a = new list
|
|
pop %di # grab Cdr(x)
|
|
jmp Pairlis
|
|
.switch:cmp $kAtom,%ax # atom: last builtin atom
|
|
ja .resolv # ah is zero if not above
|
|
mov (%si),%di # di = Car(x)
|
|
je .ifAtom
|
|
cmp $kCons,%al
|
|
jae .ifCons
|
|
.ifCar: cmp $kCar,%al
|
|
je Car
|
|
.ifCdr: jmp Cdr
|
|
.ifCons:mov (%bx,%si),%si # si = Cdr(x)
|
|
lodsw # si = Cadr(x)
|
|
je Cons
|
|
.isEq: xor %di,%ax
|
|
jne .retF
|
|
.retT: mov $kT,%al
|
|
ret
|
|
.ifAtom:test %di,%di # test if atom
|
|
jns .retT
|
|
.retF: xor %ax,%ax # ax = nil
|
|
ret
|
|
|
|
Assoc: mov %dx,%si # Assoc(x:ax,y:dx):ax
|
|
1: mov (%si),%di
|
|
mov (%bx,%si),%si
|
|
scasw
|
|
jne 1b
|
|
.byte 0xA9 # shifted ip; read as test, cmp
|
|
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!!
|
|
ret
|
|
|
|
1: mov (%bx,%di),%di # di = Cdr(c)
|
|
Evcon: push %di # save c
|
|
mov (%di),%si # di = Car(c)
|
|
lodsw # ax = Caar(c)
|
|
call Eval
|
|
pop %di # restore c
|
|
test %ax,%ax # nil test
|
|
jz 1b
|
|
push (%di) # push Car(c)
|
|
.EvCadr:pop %di
|
|
call Cadr # ax = Cadar(c)
|
|
# jmp Eval
|
|
|
|
Eval: test %ax,%ax # Eval(e:ax,a:dx):ax
|
|
jz 1f
|
|
jns Assoc # lookup val if atom
|
|
xchg %ax,%si # di = e
|
|
lodsw # ax = Car(e)
|
|
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
|
|
call Evlis
|
|
xchg %ax,%si
|
|
pop %ax
|
|
call Apply
|
|
pop %dx # restore A
|
|
mov %cx,%si # si = B
|
|
xchg %ax,%di
|
|
call Gc
|
|
mov %dx,%di # di = A
|
|
sub %si,%cx # cx = C - B
|
|
rep movsb
|
|
mov %di,%cx # cx = A + (C - B)
|
|
pop %dx # restore a
|
|
1: ret
|
|
|
|
.sig: .fill 512 - (2f - 1f) - (. - _start), 1, 0xce
|
|
1: .ascii " SECTORLISP v2 "
|
|
.word 0xAA55
|
|
2: .type .sig,@object
|
|
.type kQuote,@object
|
|
.type kCond,@object
|
|
.type kAtom,@object
|
|
.type kCar,@object
|
|
.type kCdr,@object
|
|
.type kCons,@object
|
|
.type kEq,@object
|