diff --git a/asm/lumbda b/asm/lumbda index dc8edcc..3d970b6 100755 Binary files a/asm/lumbda and b/asm/lumbda differ diff --git a/asm/lumbda-full b/asm/lumbda-full index 5b18819..8df53f9 100755 Binary files a/asm/lumbda-full and b/asm/lumbda-full differ diff --git a/asm/lumbda-full.o b/asm/lumbda-full.o index 259807e..be7430e 100644 Binary files a/asm/lumbda-full.o and b/asm/lumbda-full.o differ diff --git a/asm/lumbda-gc b/asm/lumbda-gc index be080c2..1650778 100755 Binary files a/asm/lumbda-gc and b/asm/lumbda-gc differ diff --git a/asm/lumbda-gc.o b/asm/lumbda-gc.o index 00bd74f..50facba 100644 Binary files a/asm/lumbda-gc.o and b/asm/lumbda-gc.o differ diff --git a/asm/lumbda.o b/asm/lumbda.o index 3735d50..4f3e82e 100644 Binary files a/asm/lumbda.o and b/asm/lumbda.o differ diff --git a/asm/lumbda.s b/asm/lumbda.s index cb7302f..97844e5 100644 --- a/asm/lumbda.s +++ b/asm/lumbda.s @@ -203,15 +203,18 @@ .equ BI_CADR, 115 .equ BI_SORT, 116 .equ BI_GENSYM, 117 +.equ BI_EXIT, 118 +.equ BI_VALUES, 119 +.equ BI_CWV, 120 .ifdef GC_NAIVE -.equ BI_GC_COLLECT, 118 -.equ BI_GC_STATS, 119 -.equ BI_WITH_ARENA, 120 -.equ BI_ARENA_STATS, 121 -.equ BI_ARENA_SET_MODE, 122 -.equ BI_COUNT, 123 +.equ BI_GC_COLLECT, 121 +.equ BI_GC_STATS, 122 +.equ BI_WITH_ARENA, 123 +.equ BI_ARENA_STATS, 124 +.equ BI_ARENA_SET_MODE, 125 +.equ BI_COUNT, 126 .else -.equ BI_COUNT, 118 +.equ BI_COUNT, 121 .endif # ============================================================ @@ -363,6 +366,9 @@ bn_hslist: .byte 14; .ascii "hash-set->list" bn_cadr: .byte 4; .ascii "cadr" bn_sort: .byte 4; .ascii "sort" bn_gensym: .byte 6; .ascii "gensym" +bn_exit: .byte 4; .ascii "exit" +bn_values: .byte 6; .ascii "values" +bn_cwv: .byte 16; .ascii "call-with-values" .ifdef GC_NAIVE bn_gccollect: .byte 10; .ascii "gc-collect" bn_gcstats: .byte 8; .ascii "gc-stats" @@ -423,6 +429,8 @@ cl_full_prelude: .equ cl_full_prelude_len, . - cl_full_prelude .endif +bn_mval_tag: .byte 17; .ascii "__values-marker__" + portal_magic: .ascii "LUMBDAB2" .equ PORTAL_MAGIC_LEN, 8 # magic(8) + heap_size(8) + heap_base(8) + r14(8) + r15(8) @@ -464,7 +472,7 @@ bi_names: .quad bn_isqrt .quad bn_randomseed, bn_randomint, bn_randomstate, bn_randomstateset .quad bn_randomseedfromos - .quad bn_cadr, bn_sort, bn_gensym + .quad bn_cadr, bn_sort, bn_gensym, bn_exit, bn_values, bn_cwv .ifdef GC_NAIVE .quad bn_gccollect, bn_gcstats, bn_witharena, bn_arenastats, bn_arenamode .endif @@ -565,6 +573,7 @@ sym_hash_buckets: .skip 8192 # 1024 * 8 bytes gensym_counter: .skip 8 # bumped each call to (gensym) num_buf_lp: .skip 64 # scratch [len:byte][chars...] for intern +mval_marker: .skip 8 # interned symbol; marks multi-value packets .ifdef CL_FULL # macro_env_head — linked list of (sym, closure, next) 24-byte nodes. @@ -1945,10 +1954,65 @@ scheme_read: je .sr_true cmpb $'f', %al je .sr_false + cmpb $'(', %al + je .sr_hash_vector movq $VAL_VOID, %rax popq %r12 popq %rbx ret + +.sr_hash_vector: + # `(` already consumed. Read list of elements, convert to vector. + call .read_list_elems + movq %rax, %rdi # list (tagged) + call list_to_vector_reader + popq %r12 + popq %rbx + ret + +# list_to_vector_reader: %rdi = tagged list -> %rax = tagged vector. +# Separate from bi_listtovec (which uses GETARG) so the reader can +# call it directly. +list_to_vector_reader: + pushq %rbx + movq %rdi, %rbx # save list + xorq %rcx, %rcx + movq %rdi, %rax +.l2vr_count: + cmpq $VAL_NIL, %rax + je .l2vr_alloc + incq %rcx + movq %rax, %rdx + andq $-8, %rdx + movq 8(%rdx), %rax + jmp .l2vr_count +.l2vr_alloc: + pushq %rbx + pushq %rcx + leaq 8(,%rcx,8), %rdi + call heap_alloc +.ifdef GC_NAIVE + movb $HT_VECTOR, -7(%rax) +.endif + popq %rcx + popq %rbx + movq %rcx, (%rax) + leaq 8(%rax), %rdi + movq %rbx, %rdx +.l2vr_fill: + cmpq $VAL_NIL, %rdx + je .l2vr_done + movq %rdx, %rcx + andq $-8, %rcx + movq (%rcx), %rsi + movq %rsi, (%rdi) + addq $8, %rdi + movq 8(%rcx), %rdx + jmp .l2vr_fill +.l2vr_done: + orq $7, %rax + popq %rbx + ret .sr_true: movq $VAL_TRUE, %rax popq %r12 @@ -3901,6 +3965,12 @@ eval_list: je bi_sort cmpq $BI_GENSYM, %rax je bi_gensym + cmpq $BI_EXIT, %rax + je bi_exit + cmpq $BI_VALUES, %rax + je bi_values + cmpq $BI_CWV, %rax + je bi_call_with_values cmpq $BI_INTEGERP, %rax je bi_integerp cmpq $BI_PORTALSAVE, %rax @@ -4297,6 +4367,8 @@ deep_equal: jne .deq_false cmpq $TAG_STRING, %rax je .deq_string + cmpq $7, %rax # vector tag + je .deq_vector cmpq $TAG_PAIR, %rax jne .deq_false # Both pairs — compare car then cdr @@ -4350,6 +4422,36 @@ deep_equal: decq %rdx jmp .deq_str_loop +.deq_vector: + # Both vectors. Compare lengths, then recurse elementwise. + movq %rdi, %rax + andq $-8, %rax + movq %rsi, %rcx + andq $-8, %rcx + movq (%rax), %rdx # len a + cmpq (%rcx), %rdx # len a vs len b + jne .deq_false + leaq 8(%rax), %r8 # a elements + leaq 8(%rcx), %r9 # b elements +.deq_vec_loop: + testq %rdx, %rdx + jz .deq_true + pushq %r8 + pushq %r9 + pushq %rdx + movq (%r8), %rdi + movq (%r9), %rsi + call deep_equal + popq %rdx + popq %r9 + popq %r8 + cmpq $VAL_FALSE, %rax + je .deq_false + addq $8, %r8 + addq $8, %r9 + decq %rdx + jmp .deq_vec_loop + bi_abs: GETARG %rax sarq $3, %rax @@ -4729,6 +4831,86 @@ bi_gensym: call intern_static RET_VAL +# (exit [code]) — graceful termination. Missing arg → exit 0. +bi_exit: + cmpq $VAL_NIL, %r12 + je .bex_zero + GETARG %rax + sarq $3, %rax + movq %rax, %rdi + movq $SYS_EXIT, %rax + syscall +.bex_zero: + xorq %rdi, %rdi + movq $SYS_EXIT, %rax + syscall + +# (values . xs) — packs its args as a multi-value packet. +# Calling convention: if xs has exactly one element, that element is +# returned directly (so code that ignores multi-value semantics still +# works). Otherwise we build a tagged pair (mval_marker . xs) that +# call-with-values destructures. mval_marker is a gensymed symbol set +# at init, so no user-written pair can masquerade as a packet. +bi_values: + cmpq $VAL_NIL, %r12 + je .bv_empty + movq %r12, %rax + andq $-8, %rax + movq 8(%rax), %rcx # cdr + cmpq $VAL_NIL, %rcx + je .bv_single + # multi: build pair (mval_marker . args) + movq mval_marker(%rip), %rdi + movq %r12, %rsi + call make_pair + RET_VAL +.bv_single: + movq (%rax), %rax # car + RET_VAL +.bv_empty: + movq mval_marker(%rip), %rdi + movq $VAL_NIL, %rsi + call make_pair + RET_VAL + +# (call-with-values producer consumer) — invokes producer with no +# args, destructures the multi-value packet (if any), passes the +# values positionally to consumer. +bi_call_with_values: + GETARG %rbx # producer + GETARG %rcx # consumer (save in %rcx via stack) + pushq %rcx + movq %rbx, %rdi # producer + movq $VAL_NIL, %rsi # empty arg list + call apply_proc_raw + popq %rcx # consumer + # Is %rax a multi-value packet? (pair whose car = mval_marker) + movq %rax, %rdx + andq $TAG_MASK, %rdx + cmpq $TAG_PAIR, %rdx + jne .bcwv_single + movq %rax, %rdx + andq $-8, %rdx + movq (%rdx), %r8 + cmpq mval_marker(%rip), %r8 + jne .bcwv_single + # Multi-value — args = cdr of packet + movq 8(%rdx), %rsi + movq %rcx, %rdi # consumer + call apply_proc_raw + RET_VAL +.bcwv_single: + # Single value — wrap in a 1-element list and apply + pushq %rcx + movq %rax, %rdi + movq $VAL_NIL, %rsi + call make_pair + popq %rcx + movq %rax, %rsi # (result) + movq %rcx, %rdi # consumer + call apply_proc_raw + RET_VAL + # (cadr x) — second element. Shortcut: (car (cdr x)). bi_cadr: GETARG %rdi @@ -8269,6 +8451,12 @@ init_special_forms: call intern_static movq %rax, sym_else_val(%rip) + # Intern the multi-value marker symbol used by (values) and + # (call-with-values). Stored once at init. + leaq bn_mval_tag(%rip), %rdi + call intern_static + movq %rax, mval_marker(%rip) + .ifdef CL_FULL leaq sf_quasiquote(%rip), %rdi call intern_static diff --git a/tests/cl-compat.lsp b/tests/cl-compat.lsp index 0a1e043..d41c100 100644 --- a/tests/cl-compat.lsp +++ b/tests/cl-compat.lsp @@ -79,12 +79,9 @@ 25) ;; ── multiple-value-bind ────────────────────────────────────────── -;; Skipped on tiers without `values` / `call-with-values` (asm). -;; Python and C both ship them as builtins. The macro itself is -;; validated at the other tiers. -;; (check "mvb" -;; (multiple-value-bind (q r) (values 7 3) (list q r)) -;; '(7 3)) +(check "mvb" + (multiple-value-bind (q r) (values 7 3) (list q r)) + '(7 3)) ;; ── cl-loop: 14 representative patterns ───────────────────────── diff --git a/tests/ursa-scheme.lsp b/tests/ursa-scheme.lsp index bd6d15a..4ff84a0 100644 --- a/tests/ursa-scheme.lsp +++ b/tests/ursa-scheme.lsp @@ -30,12 +30,7 @@ (check "s:ll-primep-11" (lucas-lehmer-primep 11) #f) (check "s:ll-primep-13" (lucas-lehmer-primep 13) #t) (check "s:repunit-5" (repunit-value 5) 31) -;; Verify digits via vector->list so the comparison is over lists -;; (asm's equal? does not descend into vectors — lists are shared -;; across every tier's deep-equal path). -(check "s:digits-42-2" - (vector->list (digits 42 2)) - '(1 0 1 0 1 0)) +(check "s:digits-42-2" (digits 42 2) #(1 0 1 0 1 0)) (check "s:digits-roundtrip" (digits (digits 1234 16) 16) 1234) (let ((v (of-n-bits 8))) (check "s:of-n-bits" (and (>= v 128) (< v 256)) #t)) @@ -43,3 +38,4 @@ (display "══════════════════════════════") (newline) (display "ursa-scheme: ") (display *pass*) (display " passed, ") (display *fail*) (display " failed") (newline) +(if (> *fail* 0) (exit 1)) diff --git a/tests/ursa.lsp b/tests/ursa.lsp index 5af5eb0..ac11e2d 100644 --- a/tests/ursa.lsp +++ b/tests/ursa.lsp @@ -31,9 +31,7 @@ (check "s:ll-primep-11" (lucas-lehmer-primep 11) #f) (check "s:ll-primep-13" (lucas-lehmer-primep 13) #t) (check "s:repunit-5" (repunit-value 5) 31) -(check "s:digits-42-2" - (vector->list (digits 42 2)) - '(1 0 1 0 1 0)) +(check "s:digits-42-2" (digits 42 2) #(1 0 1 0 1 0)) (check "s:digits-roundtrip" (digits (digits 1234 16) 16) 1234) (let ((v (of-n-bits 8))) (check "s:of-n-bits" (and (>= v 128) (< v 256)) #t))