mirror of
https://github.com/samsonjs/sectorlisp.git
synced 2026-03-25 09:05:48 +00:00
479 lines
8.4 KiB
ArmAsm
479 lines
8.4 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 │
|
||
│ │
|
||
│ 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. │
|
||
╚─────────────────────────────────────────────────────────────────────────────*/
|
||
|
||
/ @fileoverview lisp.c built for real mode with manual tuning
|
||
/ binary footprint is approximately 960 bytes, about 40 bytes
|
||
/ of it is overhead needed to load the second 512-byte sector
|
||
/ so if we can find a way to reduce the code size another 400
|
||
/ bytes we can bootstrap the metacircular evaluator in an mbr
|
||
|
||
#define NIL 0
|
||
#define UNDEFINED 8
|
||
#define ATOM_T 30
|
||
#define ATOM_QUOTE 34
|
||
#define ATOM_ATOM 46
|
||
#define ATOM_EQ 56
|
||
#define ATOM_COND 62
|
||
#define ATOM_CAR 72
|
||
#define ATOM_CDR 80
|
||
#define ATOM_CONS 88
|
||
#define ATOM_LAMBDA 98
|
||
|
||
#define SYNTAX 0x4000
|
||
#define LOOK 0x4100
|
||
#define GLOBALS 0x4102
|
||
#define INDEX 0x4104
|
||
#define TOKEN 0x4106
|
||
#define STR 0x41c8
|
||
|
||
////////////////////////////////////////////////////////////////////////////////
|
||
.section .start,"ax",@progbits
|
||
.globl main
|
||
.code16
|
||
|
||
main: mov $SYNTAX,%bx
|
||
movb $32,32(%bx)
|
||
movb $32,13(%bx)
|
||
movb $32,10(%bx)
|
||
movw $10536,40(%bx)
|
||
movb $46,46(%bx)
|
||
mov $STR,%di
|
||
mov $kSymbols,%si
|
||
mov $57,%cx
|
||
rep movsb
|
||
0: call GetChar
|
||
mov %ax,LOOK
|
||
call GetToken
|
||
call GetObject
|
||
xchg %ax,%di
|
||
mov GLOBALS,%si
|
||
call Eval
|
||
xchg %ax,%di
|
||
call PrintObject
|
||
mov $kCrlf,%di
|
||
call PrintString
|
||
jmp 0b
|
||
|
||
PutChar:push %bx
|
||
push %bp # original ibm pc scroll up bug
|
||
mov $0x0007,%bx # normal mda/cga style page zero
|
||
xchg %di,%ax # character to display
|
||
mov $0x0E,%ah # teletype output
|
||
int $0x10 # vidya service
|
||
pop %bp # result dil→al
|
||
pop %bx
|
||
ret
|
||
|
||
GetChar:xor %ax,%ax # get keystroke
|
||
int $0x16 # keyboard service
|
||
xor %ah,%ah # ah is bios scancode
|
||
push %ax # al is ascii character
|
||
xchg %ax,%di # result is ax
|
||
call PutChar
|
||
cmp $'\r,%al
|
||
jne 1f
|
||
mov $'\n,%di
|
||
call PutChar
|
||
1: pop %ax
|
||
ret
|
||
|
||
PrintString:
|
||
mov %di,%dx
|
||
0: mov %dx,%di
|
||
mov (%di),%al
|
||
test %al,%al
|
||
je 1f
|
||
xchg %ax,%di
|
||
call PutChar
|
||
inc %dx
|
||
jmp 0b
|
||
1: ret
|
||
|
||
GetToken:
|
||
xor %bx,%bx
|
||
mov $SYNTAX,%si
|
||
mov LOOK,%ax
|
||
mov $TOKEN,%cx
|
||
0: mov %al,%bl
|
||
mov (%bx,%si),%dl
|
||
mov %dl,%bl
|
||
cmp $0x20,%dl
|
||
jne 1f
|
||
call GetChar
|
||
jmp 0b
|
||
1: test %dl,%dl
|
||
je 3f
|
||
xchg %cx,%di
|
||
stosb
|
||
xchg %di,%cx
|
||
call GetChar
|
||
jmp 4f
|
||
2: test %bl,%bl
|
||
jne 4f
|
||
xchg %cx,%di
|
||
stosb
|
||
xchg %di,%cx
|
||
call GetChar
|
||
mov %ax,%bx
|
||
mov (%bx,%si),%bl
|
||
3: test %al,%al
|
||
jne 2b
|
||
4: mov %cx,%di
|
||
movb $0,(%di)
|
||
mov %al,LOOK
|
||
ret
|
||
|
||
Assoc: xchg %si,%bx
|
||
0: test %bx,%bx
|
||
je 2f
|
||
and $-2,%bx
|
||
mov (%bx),%si
|
||
and $-2,%si
|
||
mov (%si),%ax
|
||
cmp %di,%ax
|
||
jne 1f
|
||
mov (%bx),%si
|
||
and $-2,%si
|
||
mov 2(%si),%ax
|
||
ret
|
||
1: mov 2(%bx),%bx
|
||
jmp 0b
|
||
2: xor %ax,%ax
|
||
ret
|
||
|
||
GetObject:
|
||
cmpb $40,TOKEN
|
||
je 1f
|
||
mov $TOKEN,%di
|
||
jmp Intern
|
||
1: #jmp GetList
|
||
/ 𝑠𝑙𝑖𝑑𝑒
|
||
|
||
GetList:call GetToken
|
||
mov TOKEN,%al
|
||
cmp $'),%al
|
||
je 2f
|
||
cmp $'.,%al
|
||
je 1f
|
||
call GetObject
|
||
push %ax
|
||
call GetList
|
||
xchg %ax,%si
|
||
pop %di
|
||
jmp Cons
|
||
1: call GetToken
|
||
jmp GetObject
|
||
2: xor %ax,%ax
|
||
ret
|
||
|
||
EvalCons:
|
||
push %dx # save
|
||
mov 2(%bx),%bx
|
||
mov %bx,%di
|
||
call Cadr
|
||
mov %ax,%di
|
||
mov %bp,%si
|
||
call Eval
|
||
mov %bp,%si
|
||
pop %di # restore
|
||
push %ax # save
|
||
call Arg1
|
||
pop %si # restore
|
||
xchg %ax,%di
|
||
pop %bp
|
||
/ jmp Cons
|
||
/ 𝑠𝑙𝑖𝑑𝑒
|
||
|
||
Cons: mov $INDEX,%bx
|
||
mov (%bx),%ax
|
||
addw $2,(%bx)
|
||
shl %ax
|
||
mov %ax,%bx
|
||
mov %di,(%bx)
|
||
mov %si,2(%bx)
|
||
or $1,%ax
|
||
ret
|
||
|
||
Bind: test %di,%di
|
||
je 1f
|
||
push %bp
|
||
mov %sp,%bp
|
||
push %dx
|
||
push %dx
|
||
xchg %si,%bx
|
||
and $-2,%bx
|
||
and $-2,%di
|
||
mov %di,-4(%bp)
|
||
mov 2(%bx),%si
|
||
mov 2(%di),%di
|
||
push %bx # save no. 1
|
||
call Bind
|
||
pop %bx # rest no. 1
|
||
push %ax # save no. 2
|
||
mov (%bx),%bx
|
||
mov %bx,%di
|
||
mov -2(%bp),%si
|
||
call Eval
|
||
mov -4(%bp),%di
|
||
mov (%di),%di
|
||
xchg %ax,%si
|
||
call Cons
|
||
pop %si # rest no. 2
|
||
xchg %ax,%di
|
||
leave
|
||
jmp Cons
|
||
1: xchg %dx,%ax
|
||
ret
|
||
|
||
EvalCdr:
|
||
mov %dx,%di
|
||
mov %bp,%si
|
||
call Arg1
|
||
and $-2,%ax
|
||
mov %ax,%di
|
||
mov 2(%di),%ax
|
||
pop %bp
|
||
ret
|
||
|
||
////////////////////////////////////////////////////////////////////////////////
|
||
.text
|
||
|
||
Cadr: and $-2,%di # (object >> 1) * sizeof(word)
|
||
mov 2(%di),%di # contents of decrement register
|
||
and $-2,%di # contents of address register
|
||
mov (%di),%ax
|
||
ret
|
||
|
||
Arg1: call Cadr
|
||
xchg %ax,%di
|
||
jmp Eval
|
||
|
||
PrintObject:
|
||
push %bp
|
||
mov %di,%bp
|
||
test $1,%di
|
||
setz %al
|
||
shr %di
|
||
test %al,%al
|
||
je 1f
|
||
add $STR,%di
|
||
pop %bp
|
||
jmp PrintString
|
||
1: mov $40,%di
|
||
call PutChar
|
||
2: mov %bp,%bx
|
||
and $-2,%bx
|
||
mov (%bx),%di
|
||
call PrintObject
|
||
mov %bp,%bx
|
||
and $-2,%bx
|
||
mov 2(%bx),%bx
|
||
mov %bx,%bp
|
||
test %bx,%bx
|
||
je 4f
|
||
test $1,%bl
|
||
je 3f
|
||
mov $0x20,%di
|
||
call PutChar
|
||
jmp 2b
|
||
3: mov $kDot,%di
|
||
call PrintString
|
||
mov %bp,%di
|
||
call PrintObject
|
||
4: mov $41,%di
|
||
pop %bp
|
||
jmp PutChar
|
||
|
||
Eval: push %bp
|
||
mov %di,%dx
|
||
mov %si,%bp
|
||
0: test $1,%dl
|
||
jne 1f
|
||
xchg %bp,%si
|
||
xchg %dx,%di
|
||
pop %bp
|
||
jmp Assoc
|
||
1: mov %dx,%bx
|
||
and $-2,%bx
|
||
mov (%bx),%ax
|
||
test $1,%al
|
||
je 1f
|
||
mov (%bx),%ax
|
||
and $-2,%ax
|
||
mov %ax,%di
|
||
mov (%di),%ax
|
||
cmp $ATOM_LAMBDA,%ax
|
||
jne EvalUndefined
|
||
mov 2(%bx),%si
|
||
mov (%bx),%di
|
||
push %bx
|
||
call Cadr
|
||
mov %si,%si
|
||
mov %ax,%di
|
||
mov %bp,%dx
|
||
call Bind
|
||
mov %ax,%bp
|
||
pop %bx
|
||
mov (%bx),%bx
|
||
mov %bx,%di
|
||
and $-2,%di
|
||
mov 2(%di),%di
|
||
jmp 8f
|
||
1: mov (%bx),%ax
|
||
cmp $ATOM_COND,%ax
|
||
je EvalCond
|
||
jg 2f
|
||
cmp $ATOM_ATOM,%ax
|
||
je EvalAtom
|
||
jg 1f
|
||
test %ax,%ax
|
||
je EvalUndefined
|
||
cmp $ATOM_QUOTE,%ax
|
||
jne EvalCall
|
||
xchg %dx,%di
|
||
pop %bp
|
||
jmp Cadr
|
||
1: cmp $ATOM_EQ,%ax
|
||
jne EvalCall
|
||
push %dx
|
||
mov 2(%bx),%bx
|
||
mov %bx,%di
|
||
call Cadr
|
||
mov %ax,%di
|
||
mov %bp,%si
|
||
call Eval
|
||
mov %bp,%si
|
||
pop %di # restore
|
||
push %ax # save
|
||
call Arg1
|
||
pop %dx # restore
|
||
cmp %dx,%ax
|
||
jmp 3f
|
||
2: cmp $ATOM_CDR,%ax
|
||
je EvalCdr
|
||
cmp $ATOM_CONS,%ax
|
||
je EvalCons
|
||
cmp $ATOM_CAR,%ax
|
||
jne EvalCall
|
||
mov %bp,%si
|
||
mov %dx,%di
|
||
call Arg1
|
||
and $-2,%ax
|
||
xchg %ax,%di
|
||
mov (%di),%ax
|
||
jmp 9f
|
||
EvalAtom:
|
||
mov %bp,%si
|
||
mov %dx,%di
|
||
call Arg1
|
||
test $1,%al
|
||
3: mov $ATOM_T,%ax
|
||
je 9f
|
||
xor %ax,%ax
|
||
jmp 9f
|
||
EvalCond:
|
||
mov 2(%bx),%bx
|
||
mov %bx,%bx
|
||
and $-2,%bx
|
||
mov (%bx),%di
|
||
push %bx # save
|
||
and $-2,%di
|
||
mov (%di),%di
|
||
mov %bp,%si
|
||
call Eval
|
||
test %ax,%ax
|
||
pop %bx # restore
|
||
je EvalCond
|
||
mov (%bx),%bx
|
||
mov %bx,%di
|
||
jmp 8f
|
||
EvalCall:
|
||
mov 2(%bx),%cx
|
||
mov (%bx),%bx
|
||
mov %bx,%di
|
||
mov %bp,%si
|
||
call Assoc
|
||
mov %cx,%si
|
||
mov %ax,%di
|
||
call Cons
|
||
jmp 1f
|
||
8: call Cadr
|
||
1: mov %ax,%dx
|
||
jmp 0b
|
||
EvalUndefined:
|
||
mov $UNDEFINED,%ax
|
||
9: pop %bp
|
||
ret
|
||
|
||
Intern: push %bp
|
||
xchg %di,%bx
|
||
mov $STR,%si
|
||
0: lodsb
|
||
test %al,%al
|
||
je 4f
|
||
xor %dx,%dx
|
||
1: mov %dx,%bp
|
||
mov %dx,%di
|
||
mov (%bx,%di),%cl
|
||
cmp %cl,%al
|
||
jne 3f
|
||
inc %dx
|
||
test %al,%al
|
||
jne 2f
|
||
mov %bp,%cx
|
||
sub %cx,%si
|
||
lea -STR-1(%si),%ax
|
||
jmp 6f
|
||
2: lodsb
|
||
jmp 1b
|
||
3: test %al,%al
|
||
je 0b
|
||
lodsb
|
||
jmp 3b
|
||
4: lea -1(%si),%dx
|
||
mov %dx,%di
|
||
xchg %bx,%si
|
||
0: lodsb
|
||
stosb
|
||
test %al,%al
|
||
jnz 0b
|
||
xchg %dx,%ax
|
||
sub $STR,%ax
|
||
6: shl %ax
|
||
pop %bp
|
||
ret
|
||
|
||
////////////////////////////////////////////////////////////////////////////////
|
||
.section .rodata,"a",@progbits
|
||
|
||
kDot: .string " . "
|
||
kCrlf: .string "\r\n"
|
||
kSymbols:
|
||
.string "NIL"
|
||
.string "*UNDEFINED"
|
||
.string "T"
|
||
.string "QUOTE"
|
||
.string "ATOM"
|
||
.string "EQ"
|
||
.string "COND"
|
||
.string "CAR"
|
||
.string "CDR"
|
||
.string "CONS"
|
||
.string "LAMBDA"
|
||
.string ""
|