diff --git a/stage1/init.s b/stage1/init.s index 5963864..f924922 100644 --- a/stage1/init.s +++ b/stage1/init.s @@ -58,8 +58,8 @@ start: # loop through tokens and print them call get_token # make sure token is valid - beqz a0, .Lstart_parse_done - beqz a2, .Lstart_parse_done + beqz a0, .Lstart_token_error + beqz a2, .Lstart_token_error # save the remaining buffer mv s3, a0 mv s4, a1 @@ -71,6 +71,7 @@ start: # some kind of error li t0, PARSER_STATUS_OVERFLOW beq a0, t0, .Lstart_token_overflow +.Lstart_token_error: la a0, ERR_MSG ld a1, (ERR_MSG_LENGTH) call put_buf diff --git a/stage1/memory.s b/stage1/memory.s index bf9983d..20b3081 100644 --- a/stage1/memory.s +++ b/stage1/memory.s @@ -240,7 +240,7 @@ acquire_object: 1: ret -# decrement refcount and deallocate if <= 0 +# decrement refcount and drop if <= 0 .global release_object release_object: beqz a0, 1f @@ -248,58 +248,58 @@ release_object: addi t0, t0, -1 sw t0, LISP_OBJECT_REFCOUNT(a0) bgtz t0, 1f - j deallocate_object + j drop_object 1: mv a0, zero ret # calls deallocate for an object as well as any of the memory it owns -.global deallocate_object -deallocate_object: +.global drop_object +drop_object: addi sp, sp, -24 sd ra, 0(sp) sd s1, 8(sp) # s1 = saved object address sd s2, 16(sp) # s2 = object type mv s1, a0 lwu s2, LISP_OBJECT_TYPE(s1) - beqz s2, .Ldeallocate_object_zero # most likely double free -.Ldeallocate_object_cons: + beqz s2, .Ldrop_object_zero # most likely double free +.Ldrop_object_cons: # check for CONS li t0, LISP_OBJECT_TYPE_CONS - bne s2, t0, .Ldeallocate_object_string + bne s2, t0, .Ldrop_object_string # release head ld a0, LISP_CONS_HEAD(s1) call release_object # release tail ld a0, LISP_CONS_TAIL(s1) call release_object - j .Ldeallocate_object_end -.Ldeallocate_object_string: + j .Ldrop_object_end +.Ldrop_object_string: # check for STRING li t0, LISP_OBJECT_TYPE_STRING - bne s2, t0, .Ldeallocate_object_procedure + bne s2, t0, .Ldrop_object_procedure # release the buffer x capacity ld a0, LISP_STRING_BUF(s1) ld a1, LISP_STRING_CAP(s1) call deallocate - j .Ldeallocate_object_end -.Ldeallocate_object_procedure: + j .Ldrop_object_end +.Ldrop_object_procedure: # check for PROCEDURE li t0, LISP_OBJECT_TYPE_PROCEDURE - bne s2, t0, .Ldeallocate_object_end + bne s2, t0, .Ldrop_object_end # release data ld a0, LISP_PROCEDURE_DATA(s1) call release_object - j .Ldeallocate_object_end -.Ldeallocate_object_symbol: + j .Ldrop_object_end +.Ldrop_object_symbol: # check for SYMBOL li t0, LISP_OBJECT_TYPE_SYMBOL - bne s2, t0, .Ldeallocate_object_end + bne s2, t0, .Ldrop_object_end # symbols should never be released mv a0, s1 call acquire_object j 1f -.Ldeallocate_object_zero: +.Ldrop_object_zero: # print z address and return without deallocating li a0, 'z' call putc @@ -309,7 +309,7 @@ deallocate_object: li a0, '\n' call putc j 1f -.Ldeallocate_object_end: +.Ldrop_object_end: mv a0, s1 li a1, LISP_OBJECT_SIZE call deallocate diff --git a/stage1/object.s b/stage1/object.s index 63843de..501b3aa 100644 --- a/stage1/object.s +++ b/stage1/object.s @@ -59,6 +59,16 @@ box_integer: li a0, LISP_OBJECT_TYPE_INTEGER j make_obj +# make string from buf (a0), len (a1) +# object takes ownership of the buf and will deallocate it on drop +.global box_string +box_string: + mv a3, zero + mv a2, a1 + mv a1, a0 + li a0, LISP_OBJECT_TYPE_STRING + j make_obj + # Return only head from cons in a0 # Takes ownership of reference, so make sure to acquire first if you don't want to lose the cons # Returns nil if not cons @@ -245,6 +255,8 @@ print_obj: beq t0, t1, .Lprint_obj_integer li t1, LISP_OBJECT_TYPE_SYMBOL beq t0, t1, .Lprint_obj_symbol + li t1, LISP_OBJECT_TYPE_STRING + beq t0, t1, .Lprint_obj_string li t1, LISP_OBJECT_TYPE_PROCEDURE beq t0, t1, .Lprint_obj_procedure # print if unrecognized @@ -294,6 +306,36 @@ print_obj: ld a1, LISP_SYMBOL_LEN(s1) call put_buf j .Lprint_obj_ret +.Lprint_obj_string: + # get string buf, len + addi sp, sp, -0x10 + sd s2, 0x00(sp) + sd s3, 0x08(sp) + ld s2, LISP_STRING_BUF(s1) + ld s3, LISP_STRING_LEN(s1) + # put quote + li a0, 0x22 + call putc + # loop through chars, print double quote if quote +1: + beqz s3, 2f + lb a0, (s2) + call putc + lb a0, (s2) + li t0, 0x22 + addi s2, s2, 1 + addi s3, s3, -1 + bne a0, t0, 1b # not a quote + call putc # print extra quote + j 1b +2: + # closing quote + li a0, 0x22 + call putc + ld s2, 0x00(sp) + ld s3, 0x08(sp) + addi sp, sp, 0x10 + j .Lprint_obj_ret .Lprint_obj_procedure: # print
li a0, '<' diff --git a/stage1/parser.s b/stage1/parser.s index 580bbed..3b0db11 100644 --- a/stage1/parser.s +++ b/stage1/parser.s @@ -409,7 +409,59 @@ parse_token: sd t1, PARSER_STATE_E_FLAG(s2) # set assoc j .Lparse_token_ret_ok .Lparse_token_string: - j .Lparse_token_error # WIP + # determine true length of the string + li t1, 2 + bltu s5, t1, .Lparse_token_error # string must have at least two chars: "" + addi t0, s4, 1 # current addr (skip first ") + addi t1, s5, -1 # remaining length counter (skip first ") + li t2, 0 # actual length + li t4, 0x22 # 0x22 = " +.Lparse_token_string_length_loop: + beqz t1, .Lparse_token_error # shouldn't run out of token + lb t3, (t0) + addi t0, t0, 1 + addi t1, t1, -1 + addi t2, t2, 1 + bne t3, t4, .Lparse_token_string_length_loop # not a quote + # check if the quote is followed by a quote (escape) + beqz t1, .Lparse_token_string_length_end # end of string + lb t3, (t0) + # error condition: token contains non-escaped quote in non-terminal position + bne t3, t4, .Lparse_token_error + # skip the second quote + addi t0, t0, 1 + addi t1, t1, -1 + j .Lparse_token_string_length_loop +.Lparse_token_string_length_end: + # allocate string buffer, keep length in s7 for now + addi s7, t2, -1 # the last quote is always over-counted, remove it + mv a0, s7 + li a1, 1 # byte alignment + call allocate + beqz a0, .Lparse_token_error # alloc failed + # turn the buffer into an object + mv a1, s7 + call box_string + beqz a0, .Lparse_token_error # alloc failed + # save the object into s6 + mv s6, a0 + # set up the loop to copy the string contents, handling escapes + addi t0, s4, 1 # current src addr (skip first ") + ld t1, LISP_STRING_BUF(s6) # current dest addr + ld t2, LISP_STRING_LEN(s6) # remaining length counter + li t4, 0x22 # 0x22 = " +.Lparse_token_string_copy_loop: + beqz t2, .Lparse_token_place_object # end of string + lb t3, (t0) + sb t3, (t1) + addi t0, t0, 1 + addi t1, t1, 1 + addi t2, t2, -1 + # skip a char from the src if this is a quote + # we already validated that every quote inside the string is doubled + bne t3, t4, .Lparse_token_string_copy_loop # not a quote + addi t0, t0, 1 + j .Lparse_token_string_copy_loop .Lparse_token_address: j .Lparse_token_error # WIP .Lparse_token_place_object: diff --git a/stage1/words.s b/stage1/words.s index 2638a42..b7e9571 100644 --- a/stage1/words.s +++ b/stage1/words.s @@ -116,12 +116,30 @@ INITIAL_WORDS: .ascii "car" .balign 8 + .quad car + .2byte 4 + .byte LISP_OBJECT_TYPE_INTEGER + .ascii "car$" + .balign 8 + .quad proc_cdr .2byte 3 .byte LISP_OBJECT_TYPE_PROCEDURE .ascii "cdr" .balign 8 + .quad cdr + .2byte 4 + .byte LISP_OBJECT_TYPE_INTEGER + .ascii "cdr$" + .balign 8 + + .quad uncons + .2byte 7 + .byte LISP_OBJECT_TYPE_INTEGER + .ascii "uncons$" + .balign 8 + .quad proc_proc .2byte 4 .byte LISP_OBJECT_TYPE_PROCEDURE @@ -134,6 +152,12 @@ INITIAL_WORDS: .ascii "eval" .balign 8 + .quad eval + .2byte 5 + .byte LISP_OBJECT_TYPE_INTEGER + .ascii "eval$" + .balign 8 + .quad allocate .2byte 9 .byte LISP_OBJECT_TYPE_INTEGER diff --git a/stage2.lsp b/stage2.lsp index 1f9c03a..5a1211a 100644 --- a/stage2.lsp +++ b/stage2.lsp @@ -188,7 +188,7 @@ ; Returns 1 if two objects have the same address (define ref-eq? (proc args scope (let1 a (ref (eval scope (car args))) - (let1 b (ref (eval scope (car args))) + (let1 b (ref (eval scope (cadr args))) (cleanup a (cleanup b (number-eq? a b))))))) @@ -215,20 +215,19 @@ (eval (eval scope (car args)) (cons map (eval scope (cadr args))))))) ; associate two lists into pairs +; if the second list is shorter than the first, remaining pairs will be associated to nil (define assoc (let-recursive map (proc args () (if (nil? (car args)) () - (if (nil? (cadr args)) - () + (cons (cons - (cons - (car (car args)) - (car (cadr args))) - (unquote (cons map - (cons (cdr (car args)) - (cons (cdr (cadr args)))))))))) + (car (car args)) + (car (cadr args))) + (unquote (cons map + (cons (cdr (car args)) + (cons (cdr (cadr args))))))))) ; pass evaluated first and second arg to `map` (proc args scope (unquote (cons map @@ -258,6 +257,13 @@ (concat (assoc (car def-args) (eval-list scope args)) def-scope) (cadr def-args))))) +; print hex number, plain +(define put-hex (fn (number digits) + (seq1 + (call-native put-hex$ number + (if (nil? digits) 16 digits)) + number))) + ; Get type number of object (define type-number-of (fn (arg) (let1 address (ref arg) @@ -473,7 +479,12 @@ (define \sraw (rv.instr.r 0x3b 0x5 0x20)) ; single-instruction pseudo instructions -(define \ret (fn () (\jalr $zero $ra 0))) +(define \li (fn (reg value) (\addi reg $zero value))) +(define \mv (fn (dest src) (\addi dest src 0))) +(define \j (fn (offset) (\jal $zero offset))) +(define \jr (fn (reg offset) (\jalr $zero reg offset))) +(define \callr (fn (reg offset) (\jalr $ra reg offset))) +(define \ret (fn () (\jalr $zero $ra 0))) ; functional left fold (define left-fold (fn (f val list) @@ -546,7 +557,7 @@ ; link a program ; expects multiple named sections with instructions following the name -; symbols defined in context: pc, rel, all sections +; symbols defined in context: pc, rel, rel+, all sections ; returns the address and size of the program (define link (proc program scope (let @@ -554,13 +565,20 @@ (program-size (link.program-size program)) (program-addr (allocate program-size 4)) (section-addrs (link.section-addrs program-addr program)) + (rel (proc args scope + ; [0] - pc + (- + (eval scope (car args)) + (eval scope (quote pc))))) + ; offset by one instruction + (rel+ (proc args scope + (+ 4 (eval scope (cons rel args))))) (program-scope - (cons - (cons (quote rel) (proc args scope - ; [0] - pc - (- - (eval scope (car args)) - (eval scope (quote pc))))) + (concat + ; define rel and rel+ + (assoc + (quote (rel rel+)) + (cons rel (cons rel+ ()))) (concat section-addrs scope))) (put-instruction (fn (pc instruction-expr) @@ -583,27 +601,30 @@ (cons program-addr (cons program-size ())))))) ; try a simple assembler program -(define awesome.str$ (allocate 0x8 0x1)) -(poke.b awesome.str$ - 0x61 0x77 0x65 0x73 0x6f 0x6d 0x65 0x0a -) +(define awesome.str$ (ref "Awesome string!")) (define awesome$ (car (link (start ; initialize counter, stack (\addi $sp $sp -0x10) (\sd $ra $sp 0x00) (\sd $s0 $sp 0x08) - (\addi $s0 $zero 5) + (\li $s0 5) ) (loop - ; load address of awesome.str$ to a0 - (\auipc $a0 (rel awesome.str$)) - (\addi $a0 $a0 (+ (rel awesome.str$) 4)) - ; set length = 8 - (\addi $a1 $zero 8) + ; load address of awesome.str$ to t0 + (\auipc $t0 (rel awesome.str$)) + (\addi $t0 $t0 (+ (rel awesome.str$) 4)) + ; load string buf to a0 + (\ld $a0 $t0 0x08) + ; load string len to a1 + (\ld $a1 $t0 0x10) ; load address of put-buf and call it - (\auipc $t0 (rel put-buf$)) - (\jalr $ra $t0 (+ (rel put-buf$) 4)) + (\auipc $t0 (rel put-buf$)) + (\callr $t0 (rel+ put-buf$)) + ; print newline + (\li $a0 10) + (\auipc $t0 (rel putc$)) + (\callr $t0 (rel+ putc$)) ; decrement counter (\addi $s0 $s0 -1) ; if not zero jump back to loop @@ -618,3 +639,63 @@ ) ))) (call-native awesome$) + +; create procedure from raw address, data object +(define box-procedure + (fn (address data) + (deref (poke.d + (allocate 0x20 0x8) + 0x100000005 ; type = procedure, refcount = 1 + address + (ref data))))) + +; define (error), returns exception +; we don't evaluate the args in the asm because it's easy to do that with eval-list +(define error: (box-procedure (car (link + (start + ; preserve a0 + (\addi $sp $sp -0x10) + (\sd $ra $sp 0x00) + (\sd $a0 $sp 0x08) + ; free locals (a1) + (\mv $a0 $a1) + (\auipc $ra (rel release-object$)) + (\callr $ra (rel+ release-object$)) + ; set a0 = EVAL_ERROR_EXCEPTION (-1) + (\li $a0 -1) + ; load a1 = args + (\ld $a1 $sp 0x08) + ) + (end + (\ld $ra $sp 0x00) + (\addi $sp $sp 0x10) + (\ret) + ) +)))) +(define error (proc args scope + (eval scope + (cons error: + (eval-list scope args))))) + +; print string +(define put-str (fn (string) + (if (symbol-eq? (type-of string) (quote string)) + (let1 address (ref string) + (seq1 + (call-native put-buf$ + (peek.d (+ address 0x08)) + (peek.d (+ address 0x10))) + (deref address))) + (error (quote not-a-string:) string)))) + +; put char +(define putc (fn (char) (seq1 (call-native putc$ char) char))) + +; print hex nicely +(define print-hex + (fn (number) + (seq + (put-str "0x") + (put-hex number) + (putc 10) + number)))