ref: a9b51fb3ace7e855670e737257fd4e15344cd5ca
parent: a7bb3ba3b42eaed8425699bbff9a45510ec895af
author: Sigrid Solveig Haflínudóttir <[email protected]>
date: Mon Dec 9 22:41:46 EST 2024
aset!: support multiple indices Fixes: https://todo.sr.ht/~ft/femtolisp/20
--- a/compiler.lsp
+++ b/compiler.lsp
@@ -218,6 +218,17 @@
(if (and deref (vinfo:heap? (cdr loc)))
(emit g 'car))))))
+(define (compile-aset! g env args)
+ (let ((nref (- (length args) 2)))
+ (cond ((= nref 1)
+ (compile-app g env #f (cons 'aset! args)))
+ ((> nref 1)
+ (compile-app g env #f (cons 'aref (list-head args nref)))
+ (let ((nargs (compile-arglist g env (list-tail args nref))))
+ (bcode:stack g (- nargs))
+ (emit g 'aset!)))
+ (else (argc-error 'aset! 3)))))
+
(define (compile-set! g env s rhs)
(let ((loc (lookup-sym s env 0)))
(if (eq? loc 'global)
@@ -422,7 +433,7 @@
(emit g 'shift n)))))))
(define (compile-app g env tail? x)
- (let ((head (car x)))
+ (let ((head (car x)))
(let ((head
(if (and (symbol? head)
(not (in-env? head env))
@@ -476,6 +487,8 @@
((eof-object? x)
(compile-in g env tail? (list (top-level-value 'eof-object))))
(else (emit g 'loadv x))))
+ ((eq? (car x) 'aset!)
+ (compile-aset! g env (cdr x)))
((or (not (symbol? (car x))) (bound? (car x)) (in-env? (car x) env))
(compile-app g env tail? x))
(else
--- a/flisp.boot
+++ b/flisp.boot
@@ -13,7 +13,7 @@
#fn("8000z0700}2:" #(*)) #fn("8000z0700}2:" #(/)) #fn("8000z0700}2:" #(div0)) #fn("6000n201l:" #()) #fn("6000n201m:" #()) 0 #fn("8000z0700}2:" #(vector))- #fn("7000n30182p:" #()) 0 0 0 0 0 0 0 0 0 0 0 #fn("9000n3012082>1|:" #(#fn("6000n1A061:" #())))+ #fn("8000z0700}2:" #(aset!)) 0 0 0 0 0 0 0 0 0 0 0 #fn("9000n3012082>1|:" #(#fn("6000n1A061:" #()))) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 #fn("8000z0700}2:" #(aref)) 0 0 00)
*empty-string* "" *runestring-type* (array rune) *string-type* (array
@@ -69,7 +69,7 @@
__start #fn("7000n1705040=B3D00=w14Ow24730T51@C00w14Dw24745047550426E61:" #(__init_globals*argv* *interactive* __script __rcscript repl #fn(exit)) __start)
abs #fn("6000n10EL3500U:0:" #() abs) any- #fn("7000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 aset! 3 car 1 cons 2 < 2 cadr 1 for 3 vector? 1 fixnum? 1 boolean? 1 cdr 1 atom? 1 div0 2 equal? 2 eqv? 2 pair? 1 compare 2 null? 1 not 1 number? 1 = 2 set-cdr! 2 eq? 2 builtin? 1 set-car! 2)+ #fn("7000n21B;3D0401<51;I:047001=62:" #(any) any) arg-counts #table(bound? 1 function? 1 symbol? 1 car 1 cons 2 < 2 cadr 1 for 3 vector? 1 fixnum? 1 boolean? 1 cdr 1 atom? 1 div0 2 equal? 2 eqv? 2 pair? 1 compare 2 null? 1 not 1 number? 1 = 2 set-cdr! 2 eq? 2 builtin? 1 set-car! 2) argc-error #fn(";000n2702102211Kl37023@402465:" #(error "compile error: "" expects " " argument."
" arguments.") argc-error)
@@ -129,6 +129,9 @@
compile-arglist #fn("8000n3202101>282524228261:" #(#fn(for-each) #fn("9000n170AFO054471AK62:" #(compile-inbcode:stack)) #fn(length)) compile-arglist)
+ compile-aset! #fn("=000n3208251r2~87Kl3?07101O2282P64:7387K523d07101O2475828752P5447601778287525378088U5247902262:7:22r362:" #(#fn(length)+ compile-app aset! > aref list-head compile-arglist list-tail bcode:stack emit
+ argc-error) compile-aset!)
compile-begin #fn("9000n483H3?0700182715064:83=H3>070018283<64:7001O83<5447202352474018283=64:" #(compile-invoid emit pop compile-begin) compile-begin)
compile-builtin-call #fn("=000n7207185O538;3I07283=8;52I=073858;52@30D4858<24CK086El3:07502662:750858663:8<27C[086El3:07502862:86r2l3:07502962:750858663:8<2:Cj086El3:07385K62:86Kl3:07502;62:86r2l3:07502<62:750858663:8<2=CK086El3:07502>62:750858663:8<2?CK086El3:07385K62:750858663:8<2@CM086El3<07502A2B63:750858663:8<2CCW086r2L3;07385r262:750823702D@402C8663:8<2ECc086r2l3:07502F62:7G86r2523?07508586r3~63:7385r262:7508562:" #(#fn(get)@@ -144,11 +147,11 @@
encode-byte-code bcode:code const-to-idx-vec bcode:cenv) compile-f-)
compile-if #fn("A000n470051700517005183T718351728351B3;0738351@6074508;DC=07501828<64:8;OC=07501828=64:7501O8;895547602789534780885247501828<544823<07602952@;07602:8:534780895247501828=5447808:62:" #(make-labelcaddr cdddr cadddr void compile-in emit brf mark-label ret jmp) compile-if)
- compile-in #fn(">000\x8740005000\x884000I60O?4483R3<0700183D64:83H3\xaf083EC:07102262:83KC:07102362:83DC:07102462:83OC:07102562:83qC:07102662:7783513<0710288363:2983513C07:01822;2<51e164:7102=8363:83<RS;ID0483<Z;I;047>83<1523=07?01828364:83<892@CS07A83T513>07:018283T64:7102=83T63:892BC=07C01828364:892DC>07E018283=64:892FC;07G018363:892HCD07I2J183>22K01>262:892LC@07M018283=8465:892NC>07O018283=64:892PCE07Q0183T2D7R8351P64:892SCE07:01D83T5447102T62:892UCT083TR360O@807V2W5147X0183T7Y835164:892ZCp07:01O2Hq83Te35447[7Y835151360O@807V2\\5147:01O7Y83515447102Z62:7?01828364:" #(compile-sym+ compile-in #fn(">000\x8740005000\x884000I60O?4483R3<0700183D64:83H3\xaf083EC:07102262:83KC:07102362:83DC:07102462:83OC:07102562:83qC:07102662:7783513<0710288363:2983513C07:01822;2<51e164:7102=8363:83<2>C<07?0183=63:83<RS;ID0483<Z;I;047@83<1523=07A01828364:83<892BCS07C83T513>07:018283T64:7102=83T63:892DC=07E01828364:892FC>07G018283=64:892HC;07I018363:892JCD07K2L183>22M01>262:892NC@07O018283=8465:892PC>07Q018283=64:892RCE07S0183T2F7T8351P64:892UCE07:01D83T5447102V62:892WCT083TR360O@807X2Y5147Z0183T7[835164:892\\Cp07:01O2Jq83Te35447]7[835151360O@807X2^5147:01O7[83515447102\\62:7A01828364:" #(compile-symemit load0 load1 loadt loadf loadnil fits-i8 loadi8 #fn(eof-object?)
- compile-in #fn(top-level-value) eof-object loadv in-env? compile-app quote
- self-evaluating? if compile-if begin compile-begin prog1 compile-prog1 λ
- call-with-values #fn("7000n070AF62:" #(compile-f-))+ compile-in #fn(top-level-value) eof-object loadv aset! compile-aset! in-env?
+ compile-app quote self-evaluating? if compile-if begin compile-begin prog1
+ compile-prog1 λ call-with-values #fn("7000n070AF62:" #(compile-f-)) #fn("9000n270A2105341\x85K02223AF>2152470A242515163:D:" #(emit loadv #fn(for-each) #fn("9000n170AF0O64:" #(compile-sym))closure #fn(length)))
--- a/flisp.c
+++ b/flisp.c
@@ -1073,6 +1073,7 @@
case OP_MUL: goto apply_mul;
case OP_DIV: goto apply_div;
case OP_AREF: goto apply_aref;
+ case OP_ASET: goto apply_aset;
default:
#if defined(COMPUTED_GOTO)
goto *ops[i];
@@ -1641,20 +1642,41 @@
NEXT_OP;
OP(OP_ASET)
- e = FL(stack)[FL(sp)-3];
FL(stack)[ipd] = (uintptr_t)ip;
- if(isvector(e)){- i = tofixnum(FL(stack)[FL(sp)-2]);
- if(__unlikely(i >= vector_size(e)))
- bounds_error(v, FL(stack)[FL(sp)-1]);
- vector_elt(e, i) = (v = FL(stack)[FL(sp)-1]);
- }else if(__likely(isarray(e))){- v = cvalue_array_aset(&FL(stack)[FL(sp)-3]);
+ v = FL(stack)[FL(sp)-3];
+ n = 3;
+ if(0){+ apply_aset:
+ v = FL(stack)[FL(sp)-n];
+ for(i = n-1; i >= 3; i--){+ if(isvector(v)){+ e = FL(stack)[FL(sp)-i];
+ isz = tosize(e);
+ if(__unlikely(isz >= vector_size(v)))
+ bounds_error(v, e);
+ v = vector_elt(v, isz);
+ }else if(__likely(isarray(v))){+ FL(stack)[FL(sp)-i-1] = v;
+ v = cvalue_array_aref(&FL(stack)[FL(sp)-i-1]);
+ }else{+ type_error("sequence", v);+ }
+ }
+ FL(stack)[FL(sp)-3] = v;
+ }
+ if(isvector(v)){+ e = FL(stack)[FL(sp)-2];
+ isz = tosize(e);
+ if(__unlikely(isz >= vector_size(v)))
+ bounds_error(v, e);
+ vector_elt(v, isz) = (e = FL(stack)[FL(sp)-1]);
+ }else if(__likely(isarray(v))){+ e = cvalue_array_aset(&FL(stack)[FL(sp)-3]);
}else{- type_error("sequence", e);+ type_error("sequence", v);}
- POPN(2);
- FL(stack)[FL(sp)-1] = v;
+ POPN(n);
+ PUSH(e);
NEXT_OP;
OP(OP_FOR)
--- a/gen.lsp
+++ b/gen.lsp
@@ -64,7 +64,7 @@
OP_COMPARE compare 2 (λ (x y) (compare x y))
OP_ARGC argc #f 0
OP_VECTOR vector ANYARGS (λ rest (apply vector rest))
- OP_ASET aset! 3 (λ (x y z) (aset! x y z))
+ OP_ASET aset! -3 (λ rest (apply aset! rest))
OP_LOADNIL loadnil #f 0
OP_LOADI8 loadi8 #f 0
OP_LOADVL loadv.l #f 0
--- a/opcodes.h
+++ b/opcodes.h
@@ -109,7 +109,7 @@
[OP_EQ] = {"eq?", 2}, [OP_APPLY] = {"apply", -2}, [OP_NULLP] = {"null?", 1},- [OP_ASET] = {"aset!", 3},+ [OP_ASET] = {"aset!", -3}, [OP_ATOMP] = {"atom?", 1}, [OP_NOT] = {"not", 1}, [OP_LIST] = {"list", ANYARGS},--- a/test/unittest.lsp
+++ b/test/unittest.lsp
@@ -416,14 +416,22 @@
(assert (equal? 0 (aref a 0 0)))
(assert (equal? 0 (apply aref (list a 0 0))))
(assert (equal? 2 (aref a 0 2)))
-(assert (equal? 3 (aref a 1 0)))
+(assert (equal? 3 (aref a (1+ 0) 0)))
(assert (equal? 7 (aref a 1 2)))
-(assert (equal? 5 (aref a 1 1 1)))
+(assert (equal? 5 (aref a 1 (1+ 0) 1)))
(assert-fail (aref a 1 1 3) bounds-error)
(assert (equal? (fixnum #\l) (aref #("hello") 0 2)))-(assert (equal? (fixnum #\o) (aref #("hello") 0 4)))+(assert (equal? (fixnum #\o) (aref #("hello") 0 (1+ 3)))) (assert-fail (aref #("hello") 0 5)) (assert-fail (aref #("hello") 1 0))+
+;; aset with multiple indices
+(define a #(#(0 1 2) #(3 #(4 5 6) 7)))
+(assert (equal? 8 (apply aset! (list a 0 0 8))))
+(assert (equal? 9 (aset! a 1 1 (1+ 1) 9)))
+(assert (equal? "hello" (aset! a (1+ 0) 2 "hello")))
+(assert-fail (aset! a 1 1 3 "nope"))
+(assert (equal? a #(#(8 1 2) #(3 #(4 5 9) "hello"))))
;; make many initialized tables large enough not to be stored in-line
(for 1 100 (λ (i)