2116 lines
49 KiB
NASM
2116 lines
49 KiB
NASM
|
|
|
|
section .bss
|
|
buf resb 0x100
|
|
align 8,db 0
|
|
atoms times 24 resb 8
|
|
global env
|
|
env resq 1
|
|
env_tail resq 1
|
|
;;
|
|
section .text
|
|
|
|
global get_env
|
|
get_env:
|
|
mov rax, qword [rel env]
|
|
ret
|
|
|
|
;; converts char $dil to a digit with radix $rsi, returning it in $edx. $al is set to 1 if the char is a valid digit, and 0 otherwise.
|
|
to_digit:
|
|
lea eax, [rsi - 2]
|
|
cmp eax, 35
|
|
jae .invalid
|
|
movzx rdi, dil
|
|
lea edx, [rdi - 65] ; 'A' = 65
|
|
and edx, -33 ; convert to uppercase
|
|
add edx, 10 ; 'A' should map to 10
|
|
lea eax, [rdi - 48] ; '0' = 48
|
|
cmp esi, 11
|
|
cmovb edx, eax ; if radix <= 10, then take the difference from '0'
|
|
cmp edi, 58
|
|
cmovb edx, eax ; or if char < '9', then take the difference from '0'
|
|
xor eax, eax
|
|
cmp edx, esi
|
|
setb al ; al = edx < radix
|
|
ret
|
|
.invalid:
|
|
xor eax, eax
|
|
ret
|
|
|
|
;; rdi: *u8
|
|
strlen:
|
|
xor rax, rax
|
|
.strlen_loop:
|
|
cmp byte [rdi + rax], 0
|
|
je .strlen_done
|
|
inc rax
|
|
jmp .strlen_loop
|
|
.strlen_done:
|
|
ret
|
|
|
|
;; @param lhs: (rdi, rsi)
|
|
;; @param rhs: (rdx, rcx)
|
|
;; @return al
|
|
strcmp:
|
|
cmp rcx, rsi
|
|
cmovb rsi, rcx ; if rhs is shorter, use its length for the loop
|
|
xor eax, eax
|
|
.strcmp_loop:
|
|
cmp rsi, rax
|
|
jz .strcmp_equal
|
|
movzx ecx, byte [rdx + rax]
|
|
cmp byte [rdi + rax], cl
|
|
lea rax, [rax + 1]
|
|
je .strcmp_loop
|
|
seta al ; al = lhs > rhs
|
|
sbb al, 0 ; al = al - CF
|
|
ret
|
|
.strcmp_equal:
|
|
xor eax, eax
|
|
ret
|
|
|
|
;; rdi: src
|
|
;; rsi: dst
|
|
;; rdx: len
|
|
memcpy:
|
|
.loop:
|
|
test rdx, rdx
|
|
jz .done
|
|
mov al, byte [rdi]
|
|
mov byte [rsi], al
|
|
inc rsi
|
|
inc rdi
|
|
dec rdx
|
|
jmp .loop
|
|
.done:
|
|
ret
|
|
|
|
|
|
;; fn getc(*const opaque) -> u8
|
|
extern getc
|
|
;; fn peekc(*const opaque) -> u8
|
|
extern peekc
|
|
;; fn panic(msg: *const u8) -> !
|
|
extern panic_abort
|
|
;; fn alloc(size: usize, align: usize) -> *mut u8
|
|
extern alloc
|
|
;; fn dealloc(ptr: *mut u8, size: usize, align: usize)
|
|
extern dealloc
|
|
;; fn print(obj: Obj) -> ()
|
|
extern print
|
|
|
|
do_panic_abort:
|
|
xor rdi, rdi
|
|
xor rsi, rsi
|
|
call panic_abort
|
|
int 3
|
|
|
|
align 8,db 0
|
|
global nil
|
|
nil dq 1 ; the nil object, with refcount = 1
|
|
OBJ_BYTE equ 0
|
|
OBJ_CONS equ 1
|
|
OBJ_CLOS equ 2
|
|
OBJ_ATOM equ 3
|
|
OBJ_NUM equ 4
|
|
OBJ_PRIM equ 5
|
|
OBJ_STR equ 6
|
|
OBJ_ARR equ 7
|
|
|
|
ATOM_QUOTE equ 0
|
|
ATOM_TRUE equ 1
|
|
ATOM_PLUS equ 2
|
|
ATOM_MINUS equ 3
|
|
ATOM_MUL equ 4
|
|
ATOM_DIV equ 5
|
|
ATOM_REM equ 6
|
|
ATOM_LT equ 7
|
|
ATOM_EQ equ 8
|
|
ATOM_CAR equ 9
|
|
ATOM_CDR equ 10
|
|
ATOM_NOT equ 11
|
|
ATOM_LAMBDA equ 12
|
|
ATOM_DEFINE equ 13
|
|
ATOM_EVAL equ 14
|
|
ATOM_IF equ 15
|
|
ATOM_LET equ 16
|
|
ATOM_LET_STAR equ 17
|
|
ATOM_STR_LEN equ 18
|
|
ATOM_LIST_LEN equ 19
|
|
ATOM_STR_PARTS equ 20
|
|
ATOM_SYSCALL equ 21
|
|
ATOM_PRINT_ENV equ 22
|
|
|
|
QUOTE_STR db "quote"
|
|
QUOTE_STR_LEN equ $ - QUOTE_STR
|
|
TRUE_STR db "t"
|
|
TRUE_STR_LEN equ $ - TRUE_STR
|
|
PLUS_STR db "+"
|
|
PLUS_STR_LEN equ $ - PLUS_STR
|
|
MINUS_STR db "-"
|
|
MINUS_STR_LEN equ $ - MINUS_STR
|
|
MUL_STR db "*"
|
|
MUL_STR_LEN equ $ - MUL_STR
|
|
DIV_STR db "/"
|
|
DIV_STR_LEN equ $ - DIV_STR
|
|
REM_STR db "%"
|
|
REM_STR_LEN equ $ - REM_STR
|
|
LT_STR db "<"
|
|
LT_STR_LEN equ $ - LT_STR
|
|
EQ_STR db "="
|
|
EQ_STR_LEN equ $ - EQ_STR
|
|
CAR_STR db "car"
|
|
CAR_STR_LEN equ $ - CAR_STR
|
|
CDR_STR db "cdr"
|
|
CDR_STR_LEN equ $ - CDR_STR
|
|
NOT_STR db "not"
|
|
NOT_STR_LEN equ $ - NOT_STR
|
|
LAMBDA_STR db "lambda"
|
|
LAMBDA_STR_LEN equ $ - LAMBDA_STR
|
|
DEFINE_STR db "define"
|
|
DEFINE_STR_LEN equ $ - DEFINE_STR
|
|
EVAL_STR db "eval"
|
|
EVAL_STR_LEN equ $ - EVAL_STR
|
|
IF_STR db "if"
|
|
IF_STR_LEN equ $ - IF_STR
|
|
LET_STR db "let"
|
|
LET_STR_LEN equ $ - LET_STR
|
|
LET_STAR_STR db "let*"
|
|
LET_STAR_STR_LEN equ $ - LET_STAR_STR
|
|
STR_LEN_STR db "str-len"
|
|
STR_LEN_STR_LEN equ $ - STR_LEN_STR
|
|
LIST_LEN_STR db "list-len"
|
|
LIST_LEN_STR_LEN equ $ - LIST_LEN_STR
|
|
STR_PARTS_STR db "str-parts"
|
|
STR_PARTS_STR_LEN equ $ - STR_PARTS_STR
|
|
SYSCALL_STR db "syscall"
|
|
SYSCALL_STR_LEN equ $ - SYSCALL_STR
|
|
PRINT_ENV_STR db "print-env"
|
|
PRINT_ENV_STR_LEN equ $ - PRINT_ENV_STR
|
|
|
|
SPACE_CHAR db "\Space"
|
|
SPACE_CHAR_LEN equ $ - SPACE_CHAR
|
|
NL_CHAR db "\NL"
|
|
NL_CHAR_LEN equ $ - NL_CHAR
|
|
TAB_CHAR db "\Tab"
|
|
TAB_CHAR_LEN equ $ - TAB_CHAR
|
|
|
|
;; folds all elements in the list $rdi using the binary function $rdx in the environment $rsi with an accumulator value of $rcx, returning the result in $rax
|
|
;; fn fold_list(List<T>, Env, (U, T, Env) -> U, U) -> U
|
|
fold_list:
|
|
sub rsp, 32
|
|
mov qword [rsp], rdi ; rest
|
|
mov qword [rsp + 8], rsi ; env
|
|
mov qword [rsp + 16], rcx ; acc
|
|
mov qword [rsp + 24], rdx ; func
|
|
.loop:
|
|
mov rdi, qword [rsp]
|
|
call car_cdr
|
|
mov qword [rsp], rdx ; rest = cdr
|
|
mov rsi, rax
|
|
mov rdi, qword [rsp + 16] ; $rdi = acc
|
|
mov rdx, qword [rsp + 8] ; $rdx = env
|
|
mov rax, qword [rsp + 24] ; $rax = func
|
|
call rax
|
|
mov qword [rsp + 16], rax ; update acc to result of func(acc, car)
|
|
mov rdi, qword [rsp] ; $rdi = rest
|
|
lea rsi, [rel nil]
|
|
cmp rdi, rsi
|
|
jne .loop
|
|
mov rax, qword [rsp + 16] ; return acc
|
|
add rsp, 32
|
|
ret
|
|
|
|
;; like fold_list, but requires that the list is non-empty
|
|
;; fn reduce_list(List<T>, Env, (T, T, Env) -> T) -> T
|
|
reduce_list:
|
|
mov rcx, rdx ; func
|
|
call car_cdr
|
|
lea rdi, [rel nil]
|
|
cmp rdi, rdx
|
|
je .done
|
|
mov rdi, rdx ; list
|
|
mov rdx, rcx ; func
|
|
mov rcx, rax ; acc
|
|
call fold_list
|
|
ret
|
|
.done:
|
|
mov rax, rdx
|
|
ret
|
|
|
|
;; like reduce_list, calls a predicate instead of a binary function, and returns "t" if the predicate returns non-zero for any pair of adjacent elements, and nil otherwise
|
|
;; predicate: fn (T, T, Env) -> bool
|
|
any2_list:
|
|
sub rsp, 24
|
|
mov qword [rsp], rdi ; rest
|
|
mov qword [rsp + 8], rsi ; env
|
|
mov qword [rsp + 16], rdx ; pred
|
|
.loop:
|
|
call car_cdr
|
|
mov rsi, rax
|
|
mov qword [rsp], rdx
|
|
mov rdi, rdx
|
|
lea rdx, [rel nil]
|
|
cmp rdi, rdx
|
|
je .false
|
|
call get_car ; car(rest)
|
|
mov rdi, rax
|
|
mov rdx, qword [rsp + 8] ; env
|
|
mov rax, qword [rsp + 16] ; pred
|
|
call rax
|
|
; func(car(rest), car(cdr(rest)), env)
|
|
test al, al
|
|
jnz .true
|
|
jmp .loop
|
|
.true:
|
|
mov al, 1
|
|
add rsp, 24
|
|
ret
|
|
.false:
|
|
xor al, al
|
|
add rsp, 24
|
|
ret
|
|
|
|
unwrap_num_ptr:
|
|
call obj_addr_part
|
|
sub rdi, rax
|
|
cmp rdi, OBJ_NUM
|
|
jne do_panic_abort
|
|
add rax, 8 ; point to the number value
|
|
ret
|
|
|
|
unwrap_num:
|
|
call unwrap_num_ptr
|
|
mov rax, qword [rax] ; unwrap the number value
|
|
ret
|
|
|
|
;; |a, b| {a += b; a}
|
|
p_add_inner:
|
|
push rdi
|
|
call unwrap_num_ptr
|
|
mov rdx, rax
|
|
mov rdi, rsi
|
|
call unwrap_num
|
|
add qword [rdx], rax
|
|
pop rax
|
|
ret
|
|
|
|
;; |a, b| {a -= b; a}
|
|
p_sub_inner:
|
|
push rdi
|
|
call unwrap_num_ptr
|
|
mov rdx, rax
|
|
mov rdi, rsi
|
|
call unwrap_num
|
|
sub qword [rdx], rax
|
|
pop rax
|
|
ret
|
|
|
|
;; |a, b| {a *= b; a}
|
|
p_imul_inner:
|
|
push rdi
|
|
call unwrap_num_ptr
|
|
mov rcx, rax
|
|
mov rdi, rsi
|
|
call unwrap_num
|
|
mov rdi, qword [rcx]
|
|
imul rdi
|
|
mov qword [rcx], rax
|
|
pop rax
|
|
ret
|
|
|
|
;; |a, b| {a /= b; a}
|
|
p_idiv_inner:
|
|
push rdi
|
|
call unwrap_num_ptr
|
|
mov rcx, rax
|
|
mov rdi, rsi
|
|
call unwrap_num
|
|
mov rdi, rax
|
|
mov rax, qword [rcx]
|
|
xor rdx, rdx
|
|
idiv rdi
|
|
mov qword [rcx], rax
|
|
pop rax
|
|
ret
|
|
|
|
;; |a, b| {a %= b; a}
|
|
p_irem_inner:
|
|
push rdi
|
|
call unwrap_num_ptr
|
|
mov rcx, rax
|
|
mov rdi, rsi
|
|
call unwrap_num
|
|
mov rdi, rax
|
|
mov rax, qword [rcx]
|
|
xor rdx, rdx
|
|
idiv rdi
|
|
mov qword [rcx], rdx
|
|
pop rax
|
|
ret
|
|
|
|
;; |a, b| {a < b}
|
|
p_lt_inner:
|
|
call unwrap_num
|
|
mov rdx, rax
|
|
mov rdi, rsi
|
|
call unwrap_num
|
|
cmp rdx, rax
|
|
lea rax, [rel nil]
|
|
lea rdx, [rel atoms]
|
|
mov rdx, [rdx + ATOM_TRUE * 8] ; get the "t" atom
|
|
cmovl rax, rdx ; if a < b, return "t", else return nil
|
|
ret
|
|
|
|
p_neq_inner:
|
|
call obj_eq
|
|
ret
|
|
|
|
p_lt:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call try_car_cdar
|
|
mov rdi, rax
|
|
mov rsi, rdx
|
|
call p_lt_inner
|
|
ret
|
|
|
|
p_eq:
|
|
push rsi
|
|
call eval_list
|
|
mov rdi, rax
|
|
pop rsi
|
|
lea rdx, [rel p_neq_inner]
|
|
call any2_list ; list.any(|a, b| a != b)
|
|
test al, al ; 1 if any pair is unequual
|
|
lea rax, [rel nil]
|
|
lea rsi, [rel atoms]
|
|
cmovz rax, [rsi + ATOM_TRUE * 8] ; if no pair is unequal, return "t", else return nil
|
|
ret
|
|
|
|
make_num:
|
|
push rdi
|
|
mov rdi, 16
|
|
mov rsi, 8
|
|
call alloc
|
|
mov dword [rax], 1 ; refcount = 1
|
|
pop rdi
|
|
mov qword [rax + 8], rdi ; value = number
|
|
mov rdi, rax
|
|
mov rsi, OBJ_NUM
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; sum list $rdi in env $rsi
|
|
p_add:
|
|
sub rsp, 24
|
|
mov qword [rsp + 8], rsi ; env
|
|
call eval_list
|
|
mov qword [rsp], rax ; evaled list
|
|
mov rdi, 0
|
|
call make_num
|
|
mov rcx, rax ; acc
|
|
mov rdi, qword [rsp] ; $rdi = evaled list
|
|
mov rsi, qword [rsp + 8] ; $rsi = env
|
|
lea rdx, [rel p_add_inner]
|
|
call fold_list
|
|
add rsp, 24
|
|
ret
|
|
|
|
p_sub:
|
|
sub rsp, 24
|
|
mov qword [rsp + 8], rsi ; env
|
|
call eval_list
|
|
mov qword [rsp], rax ; evaled list
|
|
mov rdi, 0
|
|
call make_num
|
|
mov rcx, rax ; acc
|
|
mov rdi, qword [rsp] ; $rdi = evaled list
|
|
mov rsi, qword [rsp + 8] ; $rsi = env
|
|
lea rdx, [rel p_sub_inner]
|
|
call fold_list
|
|
add rsp, 24
|
|
ret
|
|
|
|
p_mul:
|
|
sub rsp, 24
|
|
mov qword [rsp + 8], rsi ; env
|
|
call eval_list
|
|
mov qword [rsp], rax ; evaled list
|
|
mov rdi, 1
|
|
call make_num
|
|
mov rcx, rax ; acc
|
|
mov rdi, qword [rsp] ; $rdi = evaled list
|
|
mov rsi, qword [rsp + 8] ; $rsi = env
|
|
lea rdx, [rel p_imul_inner]
|
|
call fold_list
|
|
add rsp, 24
|
|
ret
|
|
|
|
p_div:
|
|
sub rsp, 24
|
|
mov qword [rsp + 8], rsi ; env
|
|
call eval_list
|
|
mov qword [rsp], rax ; evaled list
|
|
mov rdi, qword [rsp] ; $rdi = evaled list
|
|
mov rsi, qword [rsp + 8] ; $rsi = env
|
|
lea rdx, [rel p_idiv_inner]
|
|
call reduce_list
|
|
add rsp, 24
|
|
ret
|
|
|
|
p_rem:
|
|
sub rsp, 24
|
|
mov qword [rsp + 8], rsi ; env
|
|
call eval_list
|
|
mov qword [rsp], rax ; evaled list
|
|
mov rdi, qword [rsp] ; $rdi = evaled list
|
|
mov rsi, qword [rsp + 8] ; $rsi = env
|
|
lea rdx, [rel p_irem_inner]
|
|
call reduce_list
|
|
add rsp, 24
|
|
ret
|
|
|
|
p_car:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_caar
|
|
ret
|
|
|
|
p_cdr:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_cadr
|
|
ret
|
|
|
|
p_not:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_car
|
|
lea rsi, [rel nil]
|
|
cmp rsi, rax
|
|
lea rax, qword [rel atoms]
|
|
mov rax, [rax + ATOM_TRUE * 8] ; get the "t" atom
|
|
cmovne rax, rsi
|
|
ret
|
|
|
|
p_quote:
|
|
call get_car
|
|
ret
|
|
|
|
p_lambda:
|
|
push rsi ; save env
|
|
call get_car
|
|
push rax ; params
|
|
call get_cdr
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rsi, rax ; body
|
|
pop rdi ; params
|
|
pop rdx
|
|
cmp rdx, qword [rel env] ; if env is global env, then use nil as closure env
|
|
lea rcx, [rel nil]
|
|
cmove rdx, rcx
|
|
call clos
|
|
ret
|
|
|
|
p_define:
|
|
call get_car
|
|
push rax ; params
|
|
call get_cdr
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax
|
|
call eval
|
|
mov rsi, rax ; evaled value
|
|
mov rdi, qword [rsp] ; name
|
|
call genv_append
|
|
pop rax ; name
|
|
ret
|
|
|
|
p_eval:
|
|
push rsi
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax
|
|
pop rsi
|
|
call eval
|
|
ret
|
|
|
|
;; (if cond then else)
|
|
;; cond = car($rdi)
|
|
;; then = car(cdr($rdi))
|
|
;; else = car(cdr(cdr($rdi)))
|
|
;; result = eval(cond) ? eval(then) : eval(else)
|
|
p_if:
|
|
; eval(car(cdr(not(eval(car($rdi), $rsi)) ? cdr(rdi) : $rdi)) $rsi)
|
|
sub rsp, 16
|
|
mov qword [rsp], rdi ; save $rdi = arg
|
|
mov qword [rsp + 8], rsi ; save $rsi = env
|
|
call get_car
|
|
mov rdi, rax
|
|
call eval
|
|
mov rdi, rax
|
|
call is_nil
|
|
mov cl, al
|
|
mov rdi, qword [rsp] ; restore $rdi = arg
|
|
call get_cdr
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rsi, rax
|
|
call get_cdr
|
|
mov rdi, rax
|
|
call get_car
|
|
test cl, cl
|
|
cmovnz rsi, rax
|
|
mov rdi, rsi
|
|
mov rsi, qword [rsp + 8] ; restore $rsi = env
|
|
call eval
|
|
add rsp, 16
|
|
ret
|
|
|
|
;; (Env, (var val), Env) -> Env
|
|
;; $rdi = acc-env, $rsi = (var val), $rdx = genv
|
|
p_let_inner:
|
|
sub rsp, 16
|
|
mov qword [rsp], rdi ; acc-env
|
|
mov qword [rsp + 8], rsi ; (var val)
|
|
mov rdi, rsi
|
|
call get_cdr
|
|
mov rdi, rax ; (val . nil)
|
|
call get_car
|
|
mov rdi, rax ; val
|
|
mov rsi, rdx ; genv
|
|
call eval
|
|
mov rsi, rax ; val
|
|
mov rdi, qword [rsp + 8] ; (var val)
|
|
call get_car
|
|
mov rdi, rax ; var
|
|
mov rdx, qword [rsp] ; acc-env
|
|
call prepend ; ((var . val) . acc-env)
|
|
add rsp, 16
|
|
ret
|
|
|
|
;; (Env, (var val), Env) -> Env
|
|
;; $rdi = acc-env, $rsi = (var val), $rdx = genv
|
|
p_let_star_inner:
|
|
sub rsp, 16
|
|
mov qword [rsp], rdi ; acc-env
|
|
mov qword [rsp + 8], rsi ; (var val)
|
|
mov rdi, rsi
|
|
call get_cdar
|
|
mov rdi, rax
|
|
mov rsi, qword [rsp] ; acc-env
|
|
call eval
|
|
mov rsi, rax ; val
|
|
mov rdi, qword [rsp + 8] ; (var val)
|
|
call get_car
|
|
mov rdi, rax ; var
|
|
mov rdx, qword [rsp] ; acc-env
|
|
call prepend ; ((var . val) . acc-env)
|
|
add rsp, 16
|
|
ret
|
|
|
|
|
|
;; (let ((var1 val1) (var2 val2) ...) body)
|
|
;; $rdi = (bindings expr) where bindings = ((var1 val1) (var2 val2) ...)
|
|
p_let:
|
|
sub rsp, 24
|
|
call get_car
|
|
mov qword [rsp], rax ; bindings
|
|
call get_cdar
|
|
mov qword [rsp + 8], rax ; body
|
|
mov qword [rsp + 16], rsi ; in_env
|
|
mov rdi, qword [rsp] ; $rdi = bindings
|
|
mov rsi, qword [rsp + 16] ; $rsi = in_env
|
|
mov rcx, rsi
|
|
lea rdx, [rel p_let_inner]
|
|
call fold_list
|
|
mov rsi, rax ; body_env = fold_list(...)
|
|
mov rdi, qword [rsp + 8] ; $rdi =
|
|
call eval
|
|
add rsp, 24
|
|
ret
|
|
|
|
p_let_star:
|
|
sub rsp, 24
|
|
call get_car
|
|
mov qword [rsp], rax ; bindings
|
|
call get_cdar
|
|
mov qword [rsp + 8], rax ; body
|
|
mov qword [rsp + 16], rsi ; in_env
|
|
mov rdi, qword [rsp] ; $rdi = bindings
|
|
mov rsi, qword [rsp + 16] ; $rsi = in_env
|
|
mov rcx, rsi
|
|
lea rdx, [rel p_let_star_inner]
|
|
call fold_list
|
|
mov rsi, rax ; body_env = fold_list(...)
|
|
mov rdi, qword [rsp + 8] ; $rdi =
|
|
call eval
|
|
add rsp, 24
|
|
ret
|
|
; p_let_rec:
|
|
|
|
;; returns the length of the input list as a number
|
|
p_list_len:
|
|
call eval_list
|
|
xor rcx, rcx ; acc = 0
|
|
.len_loop:
|
|
mov rdi, rax ; list
|
|
call is_nil
|
|
test al, al
|
|
jnz .len_done
|
|
inc rcx
|
|
call get_cdr
|
|
jmp .len_loop
|
|
.len_done:
|
|
push rcx
|
|
mov rdi, 16
|
|
mov rsi, 8
|
|
call alloc
|
|
mov dword [rax], 1 ; refcount = 1
|
|
pop rcx
|
|
mov qword [rax + 8], rcx ; value = length
|
|
mov rdi, rax
|
|
mov rsi, OBJ_NUM
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; concatenates a list of strings into a single string
|
|
;; (str_concat "Hello," " my" " name is" " Alice") -> "Hello, my name is Alice"
|
|
p_str_concat:
|
|
;; appends a list of chars to a string
|
|
;; (str_append "hello" \Space \w \o \r \l \d) -> "hello world"
|
|
p_str_append:
|
|
;; return the nth element of a string
|
|
p_str_nth:
|
|
;; sets the nth element of a string to a char
|
|
p_set_nth:
|
|
;; returns a new string that is a substring from a a+b of the input string
|
|
;; (substr "hello world" 0 5) -> "hello"
|
|
p_str_substr:
|
|
;; returns 't if the haystack-string contains the needle-char , and nil otherwise
|
|
p_str_contains_char:
|
|
;; returns 't if the haystack-string contains the needle-string, and nil otherwise
|
|
;; (contains_str? "hello world" "lo wo") -> 't
|
|
p_str_contains_str:
|
|
|
|
;; returns the length of the input string as a number
|
|
p_str_len:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax
|
|
call obj_tag_part
|
|
cmp al, OBJ_STR
|
|
jne do_panic_abort
|
|
call obj_addr_part
|
|
movzx rax, dword [rax + 4]
|
|
push rax
|
|
mov rdi, 16
|
|
mov rsi, 8
|
|
call alloc
|
|
mov rdi, rax
|
|
mov dword [rdi], 1 ; refcount = 1
|
|
pop rax
|
|
mov qword [rdi + 8], rax ; value = string length
|
|
mov rsi, OBJ_NUM
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; returns the pointer and length part of the string object as a pair of numbers
|
|
p_str_decompose:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax
|
|
call obj_tag_part
|
|
cmp al, OBJ_STR
|
|
jne do_panic_abort
|
|
sub rsp, 8
|
|
call obj_addr_part
|
|
movzx rdi, dword [rax + 4] ; length
|
|
mov rsi, qword [rax + 8] ; ptr
|
|
mov qword [rsp], rsi
|
|
call make_num
|
|
mov rdi, qword [rsp] ; ptr
|
|
mov qword [rsp], rax ; length number
|
|
call make_num
|
|
mov rdi, rax ; ptr number
|
|
mov rsi, qword [rsp] ; length number
|
|
call cons
|
|
add rsp, 8
|
|
ret
|
|
|
|
;; returns the ascii value of the char
|
|
p_char_code:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax
|
|
call obj_tag_part
|
|
cmp al, OBJ_BYTE
|
|
jne do_panic_abort
|
|
shr rax, 8
|
|
and rax, 0xFF
|
|
mov rdi, rax
|
|
call make_num
|
|
ret
|
|
|
|
;; returns a char object representing the ascii value
|
|
p_make_char:
|
|
call eval_list
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax
|
|
call unwrap_num
|
|
xor rax, rax
|
|
mov ah, cl
|
|
mov al, 0 ; OBJ_BYTE
|
|
ret
|
|
|
|
;; performs a system call, returning the result as a number
|
|
;; (syscall num arg1 arg2 arg3) -> syscall(num, arg1, arg2, arg3)
|
|
p_syscall:
|
|
push r12
|
|
push r13
|
|
call eval_list
|
|
mov rdi, rax
|
|
; r11 = syscall num
|
|
; r12 = arg0
|
|
xor r11, r11
|
|
xor r12, r12
|
|
xor r13, r13
|
|
call ._next_arg ; syacall num
|
|
jnz .do_syscall
|
|
mov r11, rcx
|
|
call ._next_arg ; arg0
|
|
jnz .do_syscall
|
|
mov r12, rcx
|
|
call ._next_arg ; arg1
|
|
jnz .do_syscall
|
|
mov rsi, rcx
|
|
call ._next_arg ; arg2
|
|
jnz .do_syscall
|
|
mov r13, rcx
|
|
call ._next_arg ; arg3
|
|
jnz .do_syscall
|
|
mov r10, rcx
|
|
call ._next_arg ; arg4
|
|
jnz .do_syscall
|
|
mov r8, rcx
|
|
call ._next_arg ; arg5
|
|
jnz .do_syscall
|
|
mov r9, rcx
|
|
.do_syscall:
|
|
mov rax, r11 ; syscall num
|
|
mov rdi, r12 ; arg0
|
|
mov rdx, r13 ; arg2
|
|
syscall
|
|
mov rdi, rax
|
|
call make_num
|
|
pop r13
|
|
pop r12
|
|
ret
|
|
;; fn _next_arg(list) -> ($rcx=arg, $rdi=rest)
|
|
._next_arg:
|
|
call is_nil
|
|
test al, al
|
|
jnz ._next_arg_done
|
|
call car_cdr
|
|
mov rdi, rax ; arg
|
|
call unwrap_num
|
|
mov rdi, rdx ; rest
|
|
mov rcx, rax ; arg value
|
|
mov al, 0
|
|
test al, al
|
|
._next_arg_done:
|
|
ret
|
|
|
|
p_print_env:
|
|
mov rdi, rsi
|
|
push rdi
|
|
call print
|
|
pop rdi
|
|
lea rax, [rel nil]
|
|
ret
|
|
|
|
global init_env
|
|
;; appends var=$rdi bound to val=$rsi to the global environment
|
|
genv_append:
|
|
call cons
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons
|
|
mov rsi, rax
|
|
mov rdi, qword [rel env_tail]
|
|
call set_cdr
|
|
mov qword [rel env_tail], rsi
|
|
ret
|
|
|
|
;; appends var=atoms[$rdi] bound to val=prim($rsi) to the global environment
|
|
genv_append_atom_prim_by_idx:
|
|
lea rax, [rel atoms]
|
|
mov rdi, [rax + rdi * 8] ; get the atom pointer
|
|
call make_prim_pair
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons
|
|
mov rsi, rax
|
|
mov rdi, qword [rel env_tail]
|
|
call set_cdr
|
|
mov qword [rel env_tail], rsi
|
|
ret
|
|
|
|
init_env:
|
|
call init_atoms
|
|
|
|
lea rdi, [rel atoms]
|
|
mov rsi, [rdi + ATOM_TRUE * 8] ; get the "t" atom
|
|
mov rdi, rsi
|
|
call cons ; (t . t)
|
|
mov rdi, rax ; $rdi = (t . t)
|
|
lea rsi, [rel nil]
|
|
call cons ; ((t . t) . nil)
|
|
mov qword [rel env], rax ; env = ((t . t) . nil)
|
|
mov qword [rel env_tail], rax ; env_tail = ((t . t) . nil)
|
|
|
|
mov rdi, ATOM_QUOTE
|
|
lea rsi, [rel p_quote]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_PLUS
|
|
lea rsi, [rel p_add]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_MINUS
|
|
lea rsi, [rel p_sub]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_MUL
|
|
lea rsi, [rel p_mul]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_DIV
|
|
lea rsi, [rel p_div]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_REM
|
|
lea rsi, [rel p_rem]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_LT
|
|
lea rsi, [rel p_lt]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_EQ
|
|
lea rsi, [rel p_eq]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_CAR
|
|
lea rsi, [rel p_car]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_CDR
|
|
lea rsi, [rel p_cdr]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_NOT
|
|
lea rsi, [rel p_not]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_LAMBDA
|
|
lea rsi, [rel p_lambda]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_DEFINE
|
|
lea rsi, [rel p_define]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_EVAL
|
|
lea rsi, [rel p_eval]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_IF
|
|
lea rsi, [rel p_if]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_LET
|
|
lea rsi, [rel p_let]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_LET_STAR
|
|
lea rsi, [rel p_let_star]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_STR_LEN
|
|
lea rsi, [rel p_str_len]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_LIST_LEN
|
|
lea rsi, [rel p_list_len]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_STR_PARTS
|
|
lea rsi, [rel p_str_decompose]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_SYSCALL
|
|
lea rsi, [rel p_syscall]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rdi, ATOM_PRINT_ENV
|
|
lea rsi, [rel p_print_env]
|
|
call genv_append_atom_prim_by_idx
|
|
|
|
mov rax, qword [rel env]
|
|
ret
|
|
|
|
global init_atoms
|
|
;; makes a (atom . prim) cons cell out of an atom symbol and a primitive function pointer
|
|
make_prim_pair:
|
|
push rdi
|
|
push rsi
|
|
mov rdi, 16
|
|
mov rsi, 8
|
|
call alloc
|
|
mov dword [rax], 1 ; refcount = 1
|
|
pop rsi
|
|
mov qword [rax + 8], rsi ; pointer to primitive function
|
|
mov rdi, rax
|
|
mov rsi, OBJ_PRIM
|
|
call obj_set_tag
|
|
mov rsi, rax
|
|
pop rdi
|
|
call obj_inc_ref
|
|
call cons
|
|
ret
|
|
|
|
make_atom:
|
|
push rdi
|
|
push rsi
|
|
mov rdi, 16
|
|
mov rsi, 8
|
|
call alloc
|
|
pop rsi
|
|
pop rdi
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov dword [rax + 4], esi ; length of string
|
|
mov qword [rax + 8], rdi ; pointer to string
|
|
mov rdi, rax
|
|
mov rsi, OBJ_ATOM
|
|
call obj_set_tag
|
|
ret
|
|
|
|
init_atoms:
|
|
mov rdi, QUOTE_STR
|
|
mov rsi, QUOTE_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx], rax ; atoms[0] = "quote"
|
|
|
|
mov rdi, TRUE_STR
|
|
mov rsi, TRUE_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + 8], rax ; atoms[1] = "t"
|
|
|
|
mov rdi, PLUS_STR
|
|
mov rsi, PLUS_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_PLUS * 8], rax ; atoms[2] = "+"
|
|
|
|
mov rdi, MINUS_STR
|
|
mov rsi, MINUS_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_MINUS * 8], rax ; atoms[3] = "-"
|
|
|
|
mov rdi, MUL_STR
|
|
mov rsi, MUL_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_MUL * 8], rax ; atoms[4] = "*"
|
|
|
|
mov rdi, DIV_STR
|
|
mov rsi, DIV_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_DIV * 8], rax ; atoms[5] = "/"
|
|
|
|
mov rdi, REM_STR
|
|
mov rsi, REM_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_REM * 8], rax ; atoms[6] = "%"
|
|
|
|
mov rdi, LT_STR
|
|
mov rsi, LT_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_LT * 8], rax ; atoms[7] = "<"
|
|
|
|
mov rdi, EQ_STR
|
|
mov rsi, EQ_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_EQ * 8], rax ; atoms[8] = "="
|
|
|
|
mov rdi, CAR_STR
|
|
mov rsi, CAR_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_CAR * 8], rax ; atoms[9] = "car"
|
|
|
|
mov rdi, CDR_STR
|
|
mov rsi, CDR_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_CDR * 8], rax ; atoms[10] = "cdr"
|
|
|
|
mov rdi, NOT_STR
|
|
mov rsi, NOT_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_NOT * 8], rax ; atoms[11] = "not"
|
|
|
|
mov rdi, LAMBDA_STR
|
|
mov rsi, LAMBDA_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_LAMBDA * 8], rax ; atoms[12] = "lambda"
|
|
|
|
mov rdi, DEFINE_STR
|
|
mov rsi, DEFINE_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_DEFINE * 8], rax ; atoms[13] = "define"
|
|
|
|
mov rdi, EVAL_STR
|
|
mov rsi, EVAL_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_EVAL * 8], rax ; atoms[14] = "eval"
|
|
|
|
mov rdi, IF_STR
|
|
mov rsi, IF_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_IF * 8], rax ; atoms[15] = "if"
|
|
|
|
mov rdi, LET_STR
|
|
mov rsi, LET_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_LET * 8], rax ; atoms[16] = "let"
|
|
|
|
mov rdi, LET_STAR_STR
|
|
mov rsi, LET_STAR_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_LET_STAR * 8], rax ; atoms[17] = "let*"
|
|
|
|
mov rdi, STR_LEN_STR
|
|
mov rsi, STR_LEN_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_STR_LEN * 8], rax ; atoms[18] = "str-len"
|
|
|
|
mov rdi, LIST_LEN_STR
|
|
mov rsi, LIST_LEN_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_LIST_LEN * 8], rax ; atoms[21] = "list-len"
|
|
|
|
mov rdi, STR_PARTS_STR
|
|
mov rsi, STR_PARTS_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_STR_PARTS * 8], rax ; atoms[19] = "str-parts"
|
|
|
|
mov rdi, SYSCALL_STR
|
|
mov rsi, SYSCALL_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_SYSCALL * 8], rax ; atoms[20] = "syscall"
|
|
|
|
mov rdi, PRINT_ENV_STR
|
|
mov rsi, PRINT_ENV_STR_LEN
|
|
call make_atom
|
|
lea rcx, [rel atoms]
|
|
mov qword [rcx + ATOM_PRINT_ENV * 8], rax ; atoms[22] = "print-env"
|
|
|
|
ret
|
|
|
|
|
|
|
|
;; returns 0 if the objects pointed at by $rdi and $rsi are equal, and 1 otherwise.
|
|
obj_eq:
|
|
sub rsp, 24
|
|
cmp rdi, rsi
|
|
je .equal
|
|
mov qword [rsp], rdi ; save obj1
|
|
mov qword [rsp + 8], rsi ; save obj2
|
|
call obj_tag_part
|
|
mov byte [rsp + 16], al ; save tag1
|
|
mov rdi, qword [rsp + 8] ; restore obj2
|
|
call obj_tag_part
|
|
cmp al, byte [rsp + 16] ; compare tag2 with tag1
|
|
jne .not_equal
|
|
cmp al, OBJ_BYTE
|
|
je .compare_bytes
|
|
cmp al, OBJ_ATOM
|
|
je .compare_atoms
|
|
cmp al, OBJ_STR
|
|
je .compare_strs
|
|
cmp al, OBJ_NUM
|
|
je .compare_nums
|
|
cmp al, OBJ_CONS
|
|
je .compare_cons
|
|
cmp al, OBJ_CLOS
|
|
je .compare_clos
|
|
cmp al, OBJ_PRIM
|
|
je .compare_prims
|
|
jmp .equal
|
|
.compare_bytes:
|
|
jmp do_panic_abort
|
|
.compare_atoms:
|
|
.compare_strs:
|
|
call obj_addr_part
|
|
mov qword [rsp + 8], rax
|
|
mov rdi, qword [rsp] ; restore obj1
|
|
call obj_addr_part
|
|
movzx rdx, dword [rax + 4] ; len1
|
|
mov rcx, qword [rsp + 8] ; ptr2
|
|
movzx rbx, dword [rcx + 4] ; len2
|
|
cmp rdx, rbx
|
|
jne .not_equal
|
|
mov rdx, qword [rax + 8] ; ptr1
|
|
mov rsi, qword [rcx + 8] ; ptr2
|
|
cmp rdx, rsi
|
|
je .equal
|
|
mov rdi, rdx
|
|
mov rdx, rsi
|
|
mov rsi, rbx
|
|
mov rcx, rbx
|
|
call strcmp
|
|
test al, al
|
|
je .equal
|
|
jmp .not_equal
|
|
.compare_nums:
|
|
call obj_addr_part
|
|
mov qword [rsp + 8], rax
|
|
mov rdi, qword [rsp] ; restore obj1
|
|
call obj_addr_part
|
|
mov rdx, qword [rax + 8] ; num1
|
|
mov rcx, qword [rsp + 8]
|
|
mov rcx, qword [rcx + 8] ; num2
|
|
cmp rdx, rcx
|
|
je .equal
|
|
jmp .not_equal
|
|
.compare_cons:
|
|
.compare_clos:
|
|
mov rdi, qword [rsp] ; restore obj1
|
|
call get_cdr
|
|
mov qword [rsp + 8], rax ; save cdr1
|
|
call get_car
|
|
mov rcx, rax ; $rcx = car1
|
|
mov rdi, qword [rsp + 16] ; $rdi = obj2
|
|
call get_cdr
|
|
mov qword [rsp + 16], rax ; save cdr2
|
|
call get_car
|
|
mov rdi, rcx ; $rdi = car1
|
|
mov rsi, rax ; $rsi = car2
|
|
call obj_eq
|
|
test al, al
|
|
jne .not_equal
|
|
mov rdi, qword [rsp + 8] ; $rdi = cdr1
|
|
mov rsi, qword [rsp + 16] ; $rsi = cdr2
|
|
call obj_eq
|
|
test al, al
|
|
jne .not_equal
|
|
jmp .equal
|
|
.compare_prims:
|
|
call obj_addr_part
|
|
mov rax, qword [rax + 8] ; prim1
|
|
mov qword [rsp + 16], rax
|
|
mov rdi, qword [rsp] ; restore obj1
|
|
call obj_addr_part
|
|
mov rdx, qword [rax + 8] ; prim1
|
|
mov rcx, qword [rsp + 16] ; prim2
|
|
cmp rdx, rcx
|
|
je .equal
|
|
jmp .not_equal
|
|
.equal:
|
|
xor eax, eax
|
|
add rsp, 24
|
|
ret
|
|
.not_equal:
|
|
mov eax, 1
|
|
add rsp, 24
|
|
ret
|
|
|
|
|
|
dtor_table:
|
|
dd 0
|
|
dd dtor_table - dtor_cons
|
|
dd dtor_table - dtor_clos
|
|
dd dtor_table - dtor_atom
|
|
dd dtor_table - dtor_num
|
|
dd 0
|
|
dd dtor_table - dtor_str
|
|
dd 0
|
|
|
|
dtor_nil:
|
|
dtor_prim:
|
|
ret
|
|
dtor_cons:
|
|
dtor_clos:
|
|
push rdi
|
|
mov rdi, qword [rdi + 8] ; car
|
|
call obj_dec_ref
|
|
mov rdi, qword [rsp]
|
|
mov rdi, qword [rdi + 16] ; cdr
|
|
call obj_dec_ref
|
|
pop rdi
|
|
mov rsi, 24
|
|
mov rdx, 8
|
|
call dealloc
|
|
ret
|
|
|
|
dtor_atom:
|
|
dtor_str:
|
|
push rdi
|
|
mov rax, rdi
|
|
mov rdi, qword [rax + 8] ; pointer to string
|
|
movzx rsi, dword [rax + 4] ; length of string
|
|
mov rdx, 1
|
|
call dealloc
|
|
pop rdi
|
|
dtor_num:
|
|
mov rsi, 16
|
|
mov rdx, 8
|
|
call dealloc
|
|
ret
|
|
|
|
|
|
obj_inc_ref:
|
|
call is_nil
|
|
test al, al
|
|
jnz .done ; nil is immortal, so we're done
|
|
call obj_addr_part
|
|
inc dword [rax] ; increment the refcount
|
|
.done:
|
|
ret
|
|
|
|
obj_dec_ref:
|
|
call is_nil
|
|
test al, al
|
|
jnz .done ; nil is immortal, so we're done
|
|
call obj_tag_part
|
|
mov rsi, rax
|
|
call obj_addr_part
|
|
dec dword [rax] ; decrement the refcount
|
|
jnz .done ; if refcount != 0, we're done
|
|
lea rcx, qword [rel dtor_table]
|
|
movsxd rsi, [rcx + rsi * 4] ; get the offset of the destructor
|
|
test rsi, rsi
|
|
jz .done ; if there's no destructor, we're done
|
|
add rcx, rsi ; p_dtor = &dtor_table + dtor_table[tag]
|
|
mov rdi, rax ; set the argument for the destructor (the object pointer)
|
|
call rcx ; call the destructor
|
|
.done:
|
|
ret
|
|
|
|
obj_assert_tag:
|
|
push rax
|
|
call obj_tag_part
|
|
cmp al, sil
|
|
jne do_panic_abort
|
|
pop rax
|
|
ret
|
|
|
|
;; returns the tag part of the object handle in $rdi
|
|
obj_tag_part:
|
|
mov rax, rdi
|
|
and al, 0x7
|
|
movzx rax, al
|
|
ret
|
|
|
|
obj_into_addr_part:
|
|
and rdi, -8
|
|
ret
|
|
|
|
;; returns the address part of the object handle in $rdi
|
|
obj_addr_part:
|
|
mov rax, rdi
|
|
and rax, -8
|
|
ret
|
|
|
|
obj_set_tag_in_place:
|
|
and rdi, -8 ; clear the tag bits
|
|
or rdi, rsi ; set the new tag bits
|
|
ret
|
|
|
|
obj_set_tag:
|
|
mov rax, rdi
|
|
and rax, -8 ; clear the tag bits
|
|
or rax, rsi ; set the new tag bits
|
|
ret
|
|
|
|
;; construcst a closure object with params $rdi, body $rsi, and env $rdx
|
|
clos:
|
|
push rdx ; env
|
|
call cons ; (params . body)
|
|
mov rdi, rax
|
|
pop rsi ; env
|
|
call cons ; ((params . body) . env)
|
|
mov rdi, rax
|
|
mov rsi, OBJ_CLOS
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; constructs a cons cell ($rdi . $rsi) and returns an object pointer to it
|
|
cons:
|
|
push rdi
|
|
push rsi
|
|
mov rdi, 24 ; struct { refcount: usize, car: *const Object, cdr: *const Object }
|
|
mov rsi, 8
|
|
call alloc
|
|
pop rsi
|
|
pop rdi
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov qword [rax + 8], rdi ; car = a
|
|
mov qword [rax + 16], rsi ; cdr = b
|
|
mov rdi, rax
|
|
mov rsi, OBJ_CONS
|
|
call obj_set_tag
|
|
ret
|
|
|
|
;; returns the car and cdr of the cons cell $rdi in $rax and $rcx
|
|
;; clobers $rax, $rdx, preserves $rdi
|
|
car_cdr:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne do_panic_abort
|
|
call obj_addr_part
|
|
mov rdx, qword [rax + 16] ; cdr
|
|
mov rax, qword [rax + 8] ; car
|
|
ret
|
|
|
|
;; (a . (b . _)) => $rax = a, $rdx = b
|
|
;; (a . nil) => $rax = a, $rdx = nil
|
|
try_car_cdar:
|
|
call car_cdr
|
|
lea rdi, [rel nil]
|
|
cmp rdi, rdx
|
|
je .done
|
|
mov rdi, rdx
|
|
and rdx, 7
|
|
cmp dl, OBJ_CONS
|
|
jne do_panic_abort
|
|
call obj_into_addr_part
|
|
mov rdx, qword [rdi + 8] ; cdar
|
|
.done:
|
|
ret
|
|
|
|
get_car:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .invalid
|
|
call obj_addr_part
|
|
mov rax, qword [rax + 8] ; return the car
|
|
ret
|
|
.invalid:
|
|
xor rdi, rdi
|
|
call panic_abort
|
|
|
|
get_cdr:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .invalid
|
|
call obj_addr_part
|
|
mov rax, qword [rax + 16] ; return the cdr
|
|
ret
|
|
.invalid:
|
|
xor rdi, rdi
|
|
call panic_abort
|
|
|
|
get_caar:
|
|
call get_car
|
|
mov rdi, rax
|
|
call get_car
|
|
ret
|
|
|
|
get_cadr:
|
|
call get_car
|
|
mov rdi, rax
|
|
call get_cdr
|
|
ret
|
|
|
|
get_cdar:
|
|
call get_cdr
|
|
mov rdi, rax
|
|
call get_car
|
|
ret
|
|
|
|
get_cddr:
|
|
call get_cdr
|
|
mov rdi, rax
|
|
call get_cdr
|
|
ret
|
|
|
|
set_cdr:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .invalid
|
|
call obj_addr_part
|
|
mov qword [rax + 16], rsi ; set the cdr to
|
|
ret
|
|
.invalid:
|
|
xor rdi, rdi
|
|
call panic_abort
|
|
|
|
get_clos_env:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CLOS
|
|
jne do_panic_abort
|
|
call obj_addr_part
|
|
mov rax, qword [rax + 16] ; return the env
|
|
ret
|
|
get_clos_params:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CLOS
|
|
jne do_panic_abort
|
|
call obj_addr_part
|
|
mov rdi, qword [rax + 8] ; return the (params . body)
|
|
call get_car
|
|
ret
|
|
get_clos_body:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CLOS
|
|
jne do_panic_abort
|
|
call obj_addr_part
|
|
mov rdi, qword [rax + 8] ; return the (params . body)
|
|
call get_cdr
|
|
ret
|
|
|
|
;; returns 1 if the result of `peekc($rdi)` is $sil
|
|
;; treats all characters less than ' ' as spaces.
|
|
is_ch:
|
|
push rsi
|
|
call peekc
|
|
pop rsi
|
|
cmp al, ' '
|
|
setbe cl ; cl = al <= ' '
|
|
movzx ecx, cl
|
|
mov edx, ' '
|
|
mul ecx, edx ; cl = (al < ' ') ? ' ' : 0
|
|
cmp sil, ' '
|
|
cmove ax, cx ; al = (sil < ' ') ? cl : al
|
|
cmp al, sil
|
|
setz al ; al = al == sil
|
|
ret
|
|
|
|
next_token:
|
|
push r14
|
|
xor r14, r14
|
|
sub rsp, 16
|
|
mov qword [rsp + 8], 0 ; flags
|
|
mov qword [rsp], rdi ; source iterator
|
|
.skip_spaces:
|
|
mov rsi, ' '
|
|
call is_ch
|
|
test al, al
|
|
mov rdi, qword [rsp]
|
|
jz .skip_spaces_done
|
|
call getc
|
|
mov rdi, qword [rsp]
|
|
jmp .skip_spaces
|
|
.skip_spaces_done:
|
|
call peekc
|
|
cmp al, '('
|
|
je .leading_kw
|
|
cmp al, ')'
|
|
je .leading_kw
|
|
cmp al, "'"
|
|
je .leading_kw
|
|
cmp al, `"`
|
|
sete al
|
|
mov byte [rsp + 8], al ; set string-ness if the next char is a quote
|
|
jmp .eat
|
|
.leading_kw:
|
|
mov rdi, qword [rsp]
|
|
call getc
|
|
lea rcx, [rel buf]
|
|
lea rcx, [rcx + r14]
|
|
mov byte [rcx], al
|
|
inc r14
|
|
jmp .done
|
|
.eat:
|
|
mov rdi, qword [rsp]
|
|
call getc
|
|
; handle escapes if we're in an escape sequence
|
|
cmp byte [rsp + 9], 1
|
|
jne .skip_escape
|
|
movzx ecx, al
|
|
cmp al, `n`
|
|
mov edi, `\n`
|
|
cmove ecx, edi
|
|
cmp al, `t`
|
|
mov edi, `\t`
|
|
cmove ecx, edi
|
|
cmp al, `r`
|
|
mov edi, `\r`
|
|
cmove ecx, edi
|
|
lea rdi, [rel buf]
|
|
mov byte [rdi + r14], cl
|
|
mov byte [rsp + 9], 0
|
|
inc r14
|
|
jmp .eat
|
|
.skip_escape:
|
|
cmp al, `\\`
|
|
sete cl
|
|
mov byte [rsp + 9], cl
|
|
je .eat
|
|
|
|
lea rcx, [rel buf]
|
|
lea rcx, [rcx + r14]
|
|
mov byte [rcx], al
|
|
inc r14
|
|
|
|
cmp al, `"`
|
|
sete dl
|
|
mov cl, byte [rsp + 8] ; get string-ness
|
|
xchg cl, dl
|
|
shl dl, cl ; string-ness = 2^(num_quotes_eaten)
|
|
mov byte [rsp + 8], dl
|
|
cmp dl, 2
|
|
jg .done
|
|
cmp dl, 0
|
|
jne .eat
|
|
|
|
mov rdi, qword [rsp]
|
|
mov rsi, ' '
|
|
call is_ch
|
|
test al, al
|
|
jnz .done
|
|
|
|
mov rdi, qword [rsp]
|
|
mov rsi, '('
|
|
call is_ch
|
|
test al, al
|
|
jnz .done
|
|
|
|
mov rdi, qword [rsp]
|
|
mov rsi, ')'
|
|
call is_ch
|
|
test al, al
|
|
jnz .done
|
|
|
|
jmp .eat
|
|
.done:
|
|
lea rcx, [rel buf]
|
|
lea rax, [rcx + r14]
|
|
mov byte [rax], 0
|
|
add rsp, 16
|
|
pop r14
|
|
mov al, byte [rel buf]
|
|
ret
|
|
|
|
parse_cur_token:
|
|
push rdi
|
|
cmp byte [rel buf], '('
|
|
je .list
|
|
cmp byte [rel buf], "'"
|
|
je .quote
|
|
cmp byte [rel buf], `"`
|
|
je .string
|
|
cmp byte [rel buf], `\\`
|
|
je .char
|
|
pop rdi
|
|
call parse_atom
|
|
ret
|
|
.list:
|
|
pop rdi
|
|
call parse_list
|
|
ret
|
|
.quote:
|
|
pop rdi
|
|
call parse_quote
|
|
ret
|
|
.string:
|
|
pop rdi
|
|
call parse_string
|
|
ret
|
|
.char:
|
|
pop rdi
|
|
call parse_char
|
|
ret
|
|
|
|
;; fn parse_string(&mut iter) -> Char
|
|
parse_char:
|
|
sub rsp, 8
|
|
lea rdi, [rel buf]
|
|
call strlen
|
|
mov qword [rsp], rax ; len
|
|
lea rdi, [rel buf]
|
|
mov rsi, rax
|
|
lea rdx, [rel SPACE_CHAR]
|
|
mov rcx, SPACE_CHAR_LEN
|
|
call strcmp
|
|
test al, al
|
|
je .is_space
|
|
lea rdi, [rel buf]
|
|
mov rsi, qword [rsp] ; len
|
|
lea rdx, [rel NL_CHAR]
|
|
mov rcx, NL_CHAR_LEN
|
|
call strcmp
|
|
test al, al
|
|
je .is_newline
|
|
lea rdi, [rel buf]
|
|
mov rsi, qword [rsp] ; len
|
|
lea rdx, [rel TAB_CHAR]
|
|
mov rcx, TAB_CHAR_LEN
|
|
call strcmp
|
|
test al, al
|
|
je .is_tab
|
|
lea rdi, [rel buf]
|
|
mov ah, byte [rdi + 1] ; get the char after the backslash
|
|
.done:
|
|
add rsp, 8
|
|
mov al, 0 ; OBJ_BYTE
|
|
ret
|
|
.is_space:
|
|
mov ah, ' '
|
|
jmp .done
|
|
.is_newline:
|
|
mov ah, `\n`
|
|
jmp .done
|
|
.is_tab:
|
|
mov ah, `\t`
|
|
jmp .done
|
|
|
|
;; fn parse_string(&mut iter) -> Box<[u8]>
|
|
parse_string:
|
|
push r12
|
|
xor r12, r12
|
|
.loop:
|
|
; scan for closing quote
|
|
lea rax, [rel buf]
|
|
mov al, byte [rax + r12 + 1]
|
|
; cmp al, `\\`
|
|
; je .escape
|
|
cmp al, `"`
|
|
je .done
|
|
test al, al
|
|
jz .invalid
|
|
inc r12
|
|
jmp .loop
|
|
.done:
|
|
mov rdi, r12
|
|
mov rsi, 1
|
|
call alloc
|
|
lea rdi, [rel buf]
|
|
inc rdi
|
|
mov rsi, rax
|
|
mov rdx, r12
|
|
push rax
|
|
call memcpy
|
|
mov rdi, 16
|
|
mov rsi, 8
|
|
call alloc
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov dword [rax + 4], r12d ; length of string
|
|
pop rdi
|
|
mov qword [rax + 8], rdi ; pointer to string
|
|
mov rdi, rax
|
|
mov rsi, OBJ_STR
|
|
call obj_set_tag
|
|
pop r12
|
|
ret
|
|
.invalid:
|
|
xor rdi, rdi
|
|
call panic_abort
|
|
|
|
|
|
|
|
parse_num:
|
|
push r12
|
|
sub rsp, 16
|
|
mov qword [rsp], 0 ; acc = 0
|
|
mov dword [rsp + 8], 10 ; radix = 10
|
|
lea r12, [rel buf]
|
|
cmp byte [r12], '-' ; check for optional leading '-'
|
|
jne .skip_sign
|
|
mov qword [rsp], -1
|
|
inc r12 ; index++
|
|
.skip_sign:
|
|
cmp byte [r12], '0'
|
|
jne .skip_radix
|
|
inc r12 ; index++
|
|
mov dil, byte [r12]
|
|
cmp dil, 'x'
|
|
jne .skip_radix
|
|
inc r12 ; index++
|
|
mov qword [rsp + 4], 16 ; radix = 16
|
|
.skip_radix:
|
|
mov dil, byte [r12]
|
|
test dil, dil
|
|
jz .done
|
|
|
|
movzx rsi, dword [rsp + 8] ; radix
|
|
call to_digit
|
|
test al, al
|
|
jz .done
|
|
mov rax, qword [rsp] ; acc
|
|
mov rcx, rdx ; digit
|
|
imul rax, rsi ; acc *= radix
|
|
add rax, rcx ; acc += digit
|
|
mov qword [rsp], rax
|
|
inc r12 ; index++
|
|
jmp .skip_radix
|
|
.done:
|
|
cmp byte [r12], 0
|
|
setz al
|
|
lea rcx, [rel buf]
|
|
sub r12, rcx ; r12 = count
|
|
mul rax, r12
|
|
mov rdx, qword [rsp] ; acc
|
|
add rsp, 16
|
|
pop r12
|
|
ret
|
|
|
|
parse_atom:
|
|
call parse_num
|
|
test al, al
|
|
jz .not_num
|
|
push rdx
|
|
mov rdi, 16 ; struct { refcount: usize, value: i64 }
|
|
mov rsi, 8
|
|
call alloc
|
|
pop rdx
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov qword [rax + 8], rdx ; value = acc
|
|
mov rdi, rax
|
|
mov rsi, OBJ_NUM
|
|
call obj_set_tag
|
|
ret
|
|
.not_num:
|
|
lea rdi, [rel buf]
|
|
call strlen
|
|
push rax ; len
|
|
mov rdi, rax
|
|
mov rsi, 1
|
|
call alloc ; allocate memory for the string
|
|
pop rdx ; len
|
|
push rax ; ptr
|
|
push rdx ; len
|
|
lea rdi, [rel buf]
|
|
mov rsi, rax
|
|
call memcpy ; memcpy(ptr, buf, len)
|
|
mov rdi, 16 ; struct { refcount: u32, length: u32, ptr: *const u8 }
|
|
mov rsi, 8
|
|
call alloc ; allocate the atom object
|
|
pop rdx ; length of string
|
|
pop rcx ; pointer to string
|
|
mov dword [rax], 1 ; refcount = 1
|
|
mov dword [rax + 4], edx ; length of string
|
|
mov qword [rax + 8], rcx ; pointer to string
|
|
mov rdi, rax
|
|
mov rsi, OBJ_ATOM
|
|
call obj_set_tag
|
|
ret
|
|
|
|
parse_quote:
|
|
call parse_next_token
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons ; (t . nil)
|
|
push rax
|
|
lea rdi, [rel atoms]
|
|
mov rdi, [rdi + ATOM_QUOTE * 8] ; get the "quote" atom
|
|
push rdi
|
|
call obj_inc_ref
|
|
pop rdi ; $rdi = "quote" atom
|
|
pop rsi ; $rsi = (t . nil)
|
|
call cons ; ("quote" . (t . nil))
|
|
ret
|
|
|
|
parse_list:
|
|
sub rsp, 24
|
|
mov qword [rsp], rdi
|
|
lea rax, [rel nil]
|
|
mov qword [rsp + 8], rax ; head = nil
|
|
mov qword [rsp + 16], rax ; tail = nil
|
|
.tailcall:
|
|
mov rdi, qword [rsp]
|
|
call next_token
|
|
cmp al, ')'
|
|
je .finish
|
|
cmp al, '.'
|
|
mov rdi, qword [rsp]
|
|
jnz .list
|
|
; dotted_pair:
|
|
call parse_next_token ; if (a . b), return b since we're in the recursive call for (cons a b)
|
|
mov rsi, rax ; $rsi = b
|
|
mov rdi, qword [rsp + 8] ; $rdi = (a . nil)
|
|
call set_cdr ; set_cdr((a . nil), b) => (a . b)
|
|
mov rdi, qword [rsp]
|
|
call next_token
|
|
cmp al, ')'
|
|
jnz .invalid
|
|
jmp .finish
|
|
.list:
|
|
call parse_cur_token
|
|
mov rdi, rax
|
|
lea rsi, [rel nil]
|
|
call cons ; (t . nil)
|
|
xchg rax, qword [rsp + 16] ; replace(&mut tail, new_tail)
|
|
lea rsi, [rel nil]
|
|
cmp rax, rsi
|
|
je .init_tail ; if tail was nil, set head = tail = (t . nil)
|
|
mov rdi, rax ; $rdi = old tail
|
|
mov rsi, qword [rsp + 16] ; $rsi = new tail
|
|
call set_cdr ; set_cdr(old_tail, new_tail) => (old_tail . (t . nil))
|
|
jmp .tailcall
|
|
.init_tail:
|
|
mov rax, qword [rsp + 16] ; $rax = (t . nil)
|
|
mov qword [rsp + 8], rax ; head = (t . nil)
|
|
jmp .tailcall
|
|
.invalid:
|
|
xor rdi, rdi
|
|
call panic_abort
|
|
.finish:
|
|
mov rax, [rsp + 8] ; the list we've been building up
|
|
add rsp, 24
|
|
ret
|
|
|
|
global parse_next_token
|
|
parse_next_token:
|
|
push rdi
|
|
call next_token
|
|
pop rdi
|
|
call parse_cur_token
|
|
ret
|
|
|
|
global eval
|
|
;; evaluates the expression in $rdi in the environment $rsi and returns the result in $rax
|
|
eval:
|
|
call obj_tag_part
|
|
cmp al, OBJ_ATOM
|
|
je .eval_atom
|
|
cmp al, OBJ_CONS
|
|
jne .uneval
|
|
; eval_list($rdi, $rsi)
|
|
sub rsp, 16
|
|
mov qword [rsp], rsi ; env
|
|
call get_cdr
|
|
mov qword [rsp + 8], rax ; cdr($rdi)
|
|
call get_car
|
|
mov rdi, rax ; $rdi = car($rdi)
|
|
mov rsi, qword [rsp] ; $rsi = env
|
|
call eval ; $rax = eval(car($rdi), $rsi)
|
|
mov rdi, rax ; $rdi = eval(car($rdi),
|
|
mov rsi, qword [rsp + 8] ; $rsi = cdr($rdi)
|
|
mov rdx, qword [rsp] ; $rdx = env
|
|
call apply
|
|
add rsp, 16
|
|
ret
|
|
.eval_atom:
|
|
call assoc
|
|
ret
|
|
.uneval:
|
|
mov rax, rdi
|
|
ret
|
|
|
|
;; returns a list of the evaluated elements in the list in $rdi in the environment $rsi
|
|
eval_list:
|
|
sub rsp, 32
|
|
mov qword [rsp], rsi ; save the environment on the stack
|
|
lea rax, [rel nil]
|
|
mov qword [rsp + 8], rax ; tail = nil
|
|
mov qword [rsp + 16], rax ; head = nil
|
|
.tailcall:
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .not_cons
|
|
; cons(eval(car($rdi), $rsi), eval_list(cdr($rdi), $rsi))
|
|
call get_car
|
|
mov rcx, rax
|
|
call get_cdr
|
|
mov qword [rsp + 24], rax ; cdr($rdi)
|
|
mov rdi, rcx ; $rdi = car($rdi)
|
|
mov rsi, qword [rsp] ; $rsi = environment
|
|
call eval
|
|
mov rdi, rax ; $rdi = eval(car($rdi), $rsi)
|
|
lea rsi, [rel nil] ; nil
|
|
call cons ; $rax = cons(eval(car($rdi), $rsi), 'nil)
|
|
xchg rax, qword [rsp + 8] ; replace(&mut tail, new_tail)
|
|
lea rsi, [rel nil]
|
|
cmp rax, rsi
|
|
jne .has_init_head
|
|
mov rax, qword [rsp + 8] ; $rax = new tail
|
|
mov qword [rsp + 16], rax ; head = new tail
|
|
mov rdi, qword [rsp + 24] ; $rdi = cdr($rdi)
|
|
jmp .tailcall
|
|
.has_init_head:
|
|
mov rdi, rax
|
|
mov rsi, qword [rsp + 8]
|
|
call set_cdr
|
|
mov rdi, qword [rsp + 24] ; $rdi = cdr($rdi)
|
|
jmp .tailcall
|
|
.not_cons:
|
|
call is_nil
|
|
test al, al
|
|
jnz .nil
|
|
mov rsi, qword [rsp] ; $rsi = environment
|
|
call eval
|
|
mov rsi, rax
|
|
mov rdi, qword [rsp + 8] ; $rdi = tail
|
|
; cdr of tail starts as nil, in the case of a cons cell as a list, we want to update it to be the eval of the cdr of the list
|
|
call set_cdr ; set_cdr(tail, eval($rdi, $rsi))
|
|
.nil:
|
|
; the tail starts as nil
|
|
mov rax, qword [rsp + 16] ; $rax = head
|
|
add rsp, 32
|
|
ret
|
|
|
|
;; returns the value associated with the symbol in $rdi in the environment $rsi, or nil if not found
|
|
assoc:
|
|
sub rsp, 16
|
|
mov qword [rsp], rsi ; save the environment on the
|
|
mov qword [rsp + 8], rdi ; save the symbol on the stack
|
|
.assoc_loop:
|
|
mov rdi, qword [rsp] ; $rdi = environment
|
|
call is_nil
|
|
test al, al
|
|
jnz .not_found ; if we've reached the end of the environment, return nil
|
|
call obj_tag_part
|
|
cmp al, OBJ_CONS
|
|
jne .invalid_env
|
|
call get_car
|
|
mov rdi, rax
|
|
call get_car
|
|
mov rdi, rax ; $rdi = key
|
|
mov rsi, qword [rsp + 8] ; $rsi = sym
|
|
call obj_eq
|
|
test al, al
|
|
je .found
|
|
mov rdi, qword [rsp] ; $rdi = environment
|
|
call get_cdr
|
|
mov qword [rsp], rax ; environment = cdr(environment)
|
|
jmp .assoc_loop
|
|
.found:
|
|
mov rdi, qword [rsp] ; $rdi = environment
|
|
call get_car
|
|
mov rdi, rax
|
|
call get_cdr
|
|
add rsp, 16
|
|
ret
|
|
.invalid_env:
|
|
.not_found:
|
|
lea rax, [rel nil]
|
|
add rsp, 16
|
|
ret
|
|
|
|
|
|
;; applies the function in $rdi to the argument list in $rsi in the environment $rdx and returns the result in $rax
|
|
apply:
|
|
call obj_tag_part
|
|
cmp al, OBJ_PRIM
|
|
je .apply_prim
|
|
cmp al, OBJ_CLOS
|
|
jne .invalid_func
|
|
; closure application:
|
|
call reduce
|
|
ret
|
|
.apply_prim:
|
|
call obj_addr_part
|
|
mov rax, qword [rax + 8] ; get the function pointer
|
|
mov rdi, rsi ; $rdi = argument list
|
|
mov rsi, rdx ; $rsi = environment
|
|
jmp rax
|
|
.invalid_func:
|
|
xor rdi, rdi
|
|
call panic_abort
|
|
|
|
;; recursively binds the symbols in $rdi to the values in $rsi in the environment $rdx and returns the new environment in $rax
|
|
bind_list:
|
|
sub rsp, 16
|
|
.tailcall:
|
|
call is_nil
|
|
test al, al
|
|
jnz .done ; if there are no more symbols to bind, return the old environment
|
|
call get_car
|
|
mov rcx, rax ; key
|
|
call get_cdr
|
|
mov qword [rsp + 8], rax ; keys
|
|
mov rdi, rsi ; values
|
|
call get_car
|
|
mov rsi, rax ; val
|
|
call get_cdr
|
|
mov qword [rsp], rax ; vals
|
|
mov rdi, rcx ; $rdi = key
|
|
call prepend ; new_env = ((key . val) . old_env)
|
|
mov rdx, rax
|
|
mov rdi, qword [rsp + 8] ; $rdi = keys
|
|
mov rsi, qword [rsp] ; $rsi = vals
|
|
jmp .tailcall ; recursively bind the rest of the keys and vals in the new environment
|
|
.done:
|
|
add rsp, 16
|
|
mov rax, rdx
|
|
ret
|
|
|
|
;; applies closure $rdi to arguments $rsi and environment $rdx, returning the result in $rax
|
|
reduce:
|
|
; a closure has the following form: ((params . body) . env)
|
|
sub rsp, 32
|
|
mov qword [rsp], rdx ; eval_env
|
|
mov qword [rsp + 8], rdi ; closure
|
|
call get_clos_env
|
|
mov rdi, rax
|
|
call is_nil
|
|
test al, al
|
|
mov rax, qword [rel env] ; g_env
|
|
cmovz rax, rdi ; base_env = closure_env == nil ? g_env : closure_env
|
|
mov qword [rsp + 16], rax ; save base env at rsp + 16
|
|
mov rdi, rsi ; $rdi = args
|
|
mov rsi, qword [rsp] ; $rsi = eval_env
|
|
call eval_list ; evaled_args = eval_list(args, eval_env)
|
|
mov rsi, rax ; $rsi = evaled args
|
|
mov rdi, qword [rsp + 8] ; $rdi = closure
|
|
call get_clos_params
|
|
mov rdi, rax ; params
|
|
mov rdx, qword [rsp + 16] ; $rdx = base_env
|
|
call bind_list ; closure_env = bind_list(params, evaled_args, base_env)
|
|
mov rsi, rax ; $rsi = closure_env
|
|
mov rdi, qword [rsp + 8] ; $rdi = closure
|
|
call get_clos_body
|
|
mov rdi, rax ; $rdi = body
|
|
call eval ; eval(body, closure_env)
|
|
add rsp, 32
|
|
ret
|
|
|
|
|
|
|
|
;; k: $rdi, v: $rsi, e: $rdx -> ((k . v) . e)
|
|
prepend:
|
|
push rdx
|
|
call cons
|
|
mov rdi, rax
|
|
pop rsi
|
|
call cons
|
|
ret
|
|
|
|
;; PRIMITIVES
|
|
|
|
;; returns 1 if the object in $rdi is nil, 0 otherwise
|
|
is_nil:
|
|
lea rax, [rel nil]
|
|
cmp rdi, rax
|
|
sete al
|
|
ret
|