shithub: sl

Info  •  Files  •  Log  •  Branches

arg-supplied?: fix wrong bp offset in certain cases

--- a/boot/sl.boot

+++ b/boot/sl.boot

@@ -188,7 +188,7 @@

   vec loadv #() apply tapply aref aref2) compile-builtin-call)

             compile-f #fn("n2702101>22262:" #(call-with-values #fn("n070AF62:" #(compile-f-))

                                               #fn("n20:")) compile-f)

-            compile-f- #fn("n2Ib620862186>1_51472501T731T517415175761T52277875798;5252731518=J702:@408=88H360E@802;88518?2;8;51~757<8;522;8A5186<8:518C3=07=2>8C52@30q48;3\x8c08AJL07?872@8@893808?U@408?54@j07A877B277C277D8A527E8B5153515247?872F8@8B893808?U@408?55@30q42G8?L23I07?87893702H@402I8?53@W0893?07?872J8?53@E08;J?07?872K8?53@30q48;3B07L8708;8:8@55@30q48<3?02M8:2N8<53@408:7O08D7P7Q1518D52537R878E<52487r42;8D51r42;8<51g3p47S878ED7Q1515447?872T5247U2V7W87EG517X87518>5387r3G62:" #(#1=#fn("z0I:" #() void)

+            compile-f- #fn("n2Ib620862186>1_51472501T731T517415175761T52277875798;5252731518=J702:@408=88H360E@802;88518?2;8;51~757<8;522;8A5186<8:518C3=07=2>8C52@30q48;3\x8c08AJL07?872@8@893808?U@408?54@j07A877B277C277D8A527E8B5153515247?872F8@8B893808?U@408?55@30q42G8?L23I07?87893702H@402I8?53@W0893?07?872J8?53@E08;J?07?872K8?53@30q48;3B07L8708;8:8@55@30q48<3?02M8:2N8<53@408:8<3=02M8:8<52@408:7O08D7P7Q1518E52537R878F<52487r42;8E51r4Mp47S878FD7Q1515447?872T5247U2V7W87EG517X87518>5387r3G62:" #(#1=#fn("z0I:" #() void)

   #fn("n10<0=863J0702185>18652;J904A<8661:q:" #(any #fn("n1A0Q;3404A:")) any-duplicates)

   make-code-emitter lastcdr lambda:vars filter cons? #fn(map) caddr cddr λ #fn(length) keyword-arg?

   error "compile error: duplicate argument: " emit optargs bcode:indexfor make-perfect-hash-table

--- a/meson.build

+++ b/meson.build

@@ -395,6 +395,7 @@

 test('torus.sl', sl, args: ['torus.sl'], workdir: tests_dir)

 test('unit.sl', sl, args: ['-S', '1m', 'unittest.sl'], workdir: tests_dir)

 test('defstruct.sl', sl, args: ['defstruct.sl'], workdir: tests_dir)

+test('crash.sl', sl, args: ['crash.sl'], workdir: tests_dir)

 bootstrap = find_program(

 	'bootstrap.sh',

--- a/src/compiler.sl

+++ b/src/compiler.sl

@@ -742,13 +742,14 @@

     (when opta

       (emit-optional-arg-inits g env opta vars nreq))

-    (let* {[vars (if suppl ; "supplied?" are placed at the current frame start

-                     (append vars '(nil nil nil nil) suppl)

-                     vars)]

-           [newenv (extend-env env vars (complex-bindings (lambda:body f) vars))]}

+    (let* {[bpvars (if suppl ; "supplied?" are placed at the current frame start

+                       (append vars '(nil nil nil nil) suppl)

+                       vars)]

+           [vars (if suppl (append vars suppl) vars)]

+           [newenv (extend-env env bpvars (complex-bindings (lambda:body f) vars))]}

       (box-vars g (car newenv))

       ;; set initial stack pointer

-      (aset! g 4 (+ (length vars) 4 (length suppl)))

+      (aset! g 4 (+ (length vars) 4))

       ;; compile body and return

       (compile-in g newenv T (lambda:body f))

       (emit g 'ret)

--- a/src/cvalues.c

+++ b/src/cvalues.c

@@ -678,6 +678,8 @@

 		if(isbuiltin(v))

 			return sl_builtinsym;

 		return sl_fnsym;

+	case TAG_UNUSED:

+		abort();

 	}

 	return cv_type(ptr(v));

 }

--- /dev/null

+++ b/test/crash.sl

@@ -1,0 +1,21 @@

+;; crashed previously

+

+(def (f a (b NIL b-sup) (c NIL) . rest)

+  (def (g x)

+    (+ a x (or (and b-sup b) 0)))

+  (let* {[y (car rest)]

+         [x (or y c)]}

+    (g x)))

+

+(assert (= (f 0 0 0) 0))

+(princ "b-supplied: ok") (newline)

+

+(for 1 10 (λ (i) 0))

+(princ "loop: ok") (newline)

+

+(assert-fail (map - '(5) '("hi")))

+(assert-fail (map + '(5) '("hi")))

+(assert-fail (map / '(5) '("hi")))

+(assert-fail (map * '(5) '("hi")))

+(assert-fail (map bound? '(5) '("hi")))

+(princ "failing map: ok") (newline)

--- a/test/unittest.sl

+++ b/test/unittest.sl

@@ -188,9 +188,6 @@

 (assert (not (eqv? -0.0f 0.0f)))

 (assert (= 0.0f -0.0f))

-; this crashed once

-(for 1 10 (λ (i) 0))

-

 ; and, or

 (assert (equal? T (and)))

 (assert (equal? NIL (or)))

@@ -775,10 +772,3 @@

   `(let ((a# 2)) (list a# ,x)))

 (assert (equal? '(1 (2 3)) (f (g 3))))

-

-;; these crashed before

-(assert-fail (map - '(5) '("hi")))

-(assert-fail (map + '(5) '("hi")))

-(assert-fail (map / '(5) '("hi")))

-(assert-fail (map * '(5) '("hi")))

-(assert-fail (map bound? '(5) '("hi")))