shithub: sl

Download patch

ref: 2105ddb8e9e096adb877d922b8193166f7d60e76
parent: 81e3856ec51e1a24c73377eb3e090dda90a5c395
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Tue Apr 15 00:14:14 EDT 2025 

compiler: add "arg-supplied?" support

Implements: https://todo.sr.ht/~ft/sl/60


--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -79,7 +79,7 @@
   #fn(get) *properties* :kind *doc-extra* filter #fn("n10<20Q:" #(:doc-fmt))
   #fn("n10<20Q:" #(:doc-see)) princ foldl #fn("n20=161:") newline "See also:" #fn("n1A<0=700=21522263:" #(getprop
   *formals-list* "    ")) "Members:" #fn("n1A<070021522263:" #(getprop *formals-list* "    ")) void
-  "no help for " #fn(str) " " "" " (undefined)"))  defstruct #fn("O10005000*///W1000J7021?14W2000J60q?24W3000J60D?34W4000J60q?44W5000J60D?54z6IIb;228;230>1_5142224?<5147586518=<8==268?5127288?528<8?51121Q82;J5048C;3404085;3\\0485DCC08D;3:042902:52@D08DJ=02;2<2=52@40858C3:02>0e2@7002?e283;3\\0483H;3M0483DQ;3:04292@052;J504838BP;J5048384;J:042A02B52I222C8C18D8G848508?>8?I5148>3G07D02E8>2F8IPe15252@30q42G2He18E3{02I8E2Je28C3E02K2L2Je22M8Fe2e3@V02N2O2P2JEe32M0e2e32Q2R2Je27S8@51e3e3e3@30qe18G3\xae08C3t02H2I8G2G1e12M2Te2e12M0e2e12U7V2Wq8A535154e32X2M0e22M2Ye28G<e4e3@d02I8G8D3K02G2Ze12M8De2e12U8A5153@@02G2Ze12U8A5152e3@30qe12U7[2\\8;8B8A8H8C8E8F8D0>98@525164:" #(#(:constructor
+  "no help for " #fn(str) " " "" " (undefined)"))  defstruct #fn("O10005000*///z6W1000J7021?14W2000J60q?24W3000J60D?34W4000J60q?44W5000J60D?54IIb;228;230>1_5142224?<5147586518=<8==268?5127288?528<8?51121Q82;J5048C;3404085;3\\0485DCC08D;3:042902:52@D08DJ=02;2<2=52@40858C3:02>0e2@7002?e283;3\\0483H;3M0483DQ;3:04292@052;J504838BP;J5048384;J:042A02B52I222C8C18D8G848508?>8?I5148>3G07D02E8>2F8IPe15252@30q42G2He18E3{02I8E2Je28C3E02K2L2Je22M8Fe2e3@V02N2O2P2JEe32M0e2e32Q2R2Je27S8@51e3e3e3@30qe18G3\xae08C3t02H2I8G2G1e12M2Te2e12M0e2e12U7V2Wq8A535154e32X2M0e22M2Ye28G<e4e3@d02I8G8D3K02G2Ze12M8De2e12U8A5153@@02G2Ze12U8A5152e3@30qe12U7[2\\8;8B8A8H8C8E8F8D0>98@525164:" #(#(:constructor
   2 :predicate 4 NIL NIL :type 0 :named 1 :conc-name 3 NIL NIL) vec #0#
   #fn("n17005121220A>28552485:" #(cddr #fn(for-each)
                                   #fn("n17002152340q:722324A<25F2605661:" #(member (:read-only)
@@ -188,12 +188,13 @@
   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_51472501T731T517415175761T52731518<J7027@408<88H360E@802888518>288;51~75798;5286<8:518A3=07:2;8A52@30q48;3\xa208@JL07<872=8?893808>U@408>54@r07>877?2@7A2@7B8@527C288@515153515247<872D8?288@51893808>U@408>5547E8708;8:8?55@30q42F8>L23I07<87893702G@402H8>53@W0893?07<872I8>53@E08;J?07<872J8>53@30q47K08:7L7M1518:52537N878B<52487r4288:51r4Mp47O878BD7M1515447<872P5247Q2R7S87EG517T87518=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:7O08D7P7Q1518D52537R878E<52487r42;8D51r42;8<51g3p47S878ED7Q1515447?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(length) keyword-arg? error "compile error: duplicate argument: "
-  emit optargs bcode:indexfor make-perfect-hash-table #fn(map) cons car iota keyargs
-  emit-optional-arg-inits 255 vargc.l argc.l vargc argc extend-env complex-bindings lambda:body
-  box-vars compile-in ret values #fn(fn) encode-byte-code const-to-idx-vec) compile-f-)
+  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
+  cons car iota keyargs 255 vargc.l argc.l vargc argc emit-optional-arg-inits #fn(append)
+  (NIL NIL NIL NIL) extend-env complex-bindings lambda:body box-vars compile-in ret values #fn(fn)
+  encode-byte-code const-to-idx-vec) compile-f-)
             compile-if #fn("n420502050205083T718351728351B3;0738351@30q8;DC=07401828<64:8;J=07401828=64:7401q8;89554750268953475027885347401828<544823<07502852@;0750298:53475027895347401828=544750278:63:" #(#fn(gensym)
   caddr cdddr cadddr compile-in emit brn label ret jmp) compile-if)
             compile-in #fn("\x8740005000W4000J60q?4483R3<0700183D64:83H3\x97083EC:07102262:83KC:07102362:83DC:07102462:83J:07102562:7683513:07102762:7883513<0710298363:7102:8363:83<2;C<07<0183=63:83<RS;JD0483<Z;J;047=83<1523=07>01828364:83<892?CS07@83T513>07A018283T64:7102:83T63:892BC=07C01828364:892DC>07E018283=64:892FC;07G018363:892HCD07I2J183>22K01>262:892LC@07M018283=8465:892NC>07O018283=64:892PCE07Q0183T2D7R8351P64:892SCS07A01D83=B38083T@607T505447102U62:892VC\x91083T7W7R8351518;<<8;=8:R360q@807X2Y5148<3Y07Z8:8<8=<B;3F048=<<2HQ;3:047[8=<5153@30q47\\018:8=<64:892]Cp07A01q2Hq83Te35447^7_835151360q@807X2`5147A01q7_83515447102]62:7>01828364:" #(compile-sym
@@ -245,8 +246,9 @@
   loada.l)
                                                                (seta seta.l) (box box.l)) 255 ((loadc
   loadc.l)) loada (0) loada0 (1) loada1 loadc loadc0 loadc1 brn not brnn eq? brne nreconc) emit)
-            emit-optional-arg-inits #fn("n582B3\x91020507102284534710238953474075176838452q53q7782515447102884534710295247102:895347;0182=8384KM65:q:" #(#fn(gensym)
-  emit brbound brnn compile-in extend-env list-head cadar seta pop label emit-optional-arg-inits) emit-optional-arg-inits)
+            emit-optional-arg-inits #fn("n582B3\xa60205071022845347382513<07102452@30q4710258953476077178838452q53q7982515447102:845347102;5247102<895347=0182=8384KM65:q:" #(#fn(gensym)
+  emit brbound cddar dup brnn compile-in extend-env list-head cadar seta pop label
+  emit-optional-arg-inits) emit-optional-arg-inits)
             encode-byte-code #fn("n17005171855172238651r3238651r2ki2M2452238651E255025502650qqI8988L23\xbc148689G?=48=27CP0288:8689KMG298<5153489r2M?9@\x8b12:8<2;7<873k08=8C2=C702>@X08C2?C702@@L08C2AC702B@@08C2CC702D@408=^1@408=5252489KM?948988L2;38048689G?>42E8=2F523`0288;298<518>5342:8<873707G@407HE5152489KM?9@\xeb08=2ICH02:8<2J8>5152489KM?9@\xce08>X3\xc708=2E8?2K523H02:8<2J8>5152489KM?9@\x9f02E8?2L523\x8102:8<2J8>5152489KM?942:8<2J8689G5152489KM?948=2MCK02:8<2J8689G5152489KM?9@30q@E02:8<2N8>5152489KM?9^1@30q@\x9f.42O2P8<878:>38;5242Q8<61:" #(reverse!
   list->vec >= #fn(length) 65536 #fn(table) #fn(buffer) label #fn(put!)
   #fn(sizeof) #fn(io-write) #fn(get) Instructions jmp jmp.l brne brne.l brnn brnn.l brn brn.l #fn(memq)
@@ -272,7 +274,7 @@
   NIL NIL NIL NIL :from-end 3) identity #0# #fn("n10S;J;04AF0<51513500<:92<0=61:" #() find-if-)
   list-tail list-head reverse!) find-if)
             fits-i8 #fn("n10Y;3<0470r\xaf0r\xb063:" #(>=) fits-i8) fn-disasm
-            #fn("\x871000.///W1000J60q?14z20[3I07021122534735047460:@30q482JG07501E534735047460:@30q482<2605127051II282987>1?:514282:187>2?;514E2;8851b<I8<<8=L23\x8a242<2=888<>2q7>53E8<<L23907350@30q4E87K~2?|48<8<<KM_48>2@8?2A523[08;8>8<<r45348:897B888<<52G5148<8<<r4M_@\x1912@8?2C523V08;8>8<<K5348:89888<<GG5148<8<<KM_@\xea12@8?2D523e08;8>8<<K534702E888<<G8>2FC70r3@30EM515148<8<<KM_@\xac12@8?2G523\\08;8>8<<r4534702E7B888<<52515148<8<<r4M_@w12@8?2H523\xb808;8>8<<r88>2IC70r4@30EM534702E7B888<<52512J5248<8<<r4M_4702E7B888<<52515148<8<<r4M_48>2ICY0702J514702E7B888<<52512J5248<8<<r4M_@30q@\xe608?2Kc3^08;8>8<<r4534702E7B888<<52512J5248<8<<r4M_@\xb202@8?2L523b08;8>8<<r2534702M7N8<<7O888<<52M515248<8<<r2M_@w02@8?2P523b08;8>8<<r4534702M7N8<<7B888<<52M515248<8<<r4M_@<08;8>8<<E53^1^1@\xd0-:" #(princ
+            #fn("\x871000.///z2W1000J60q?140[3I07021122534735047460:@30q482JG07501E534735047460:@30q482<2605127051II282987>1?:514282:187>2?;514E2;8851b<I8<<8=L23\x8a242<2=888<>2q7>53E8<<L23907350@30q4E87K~2?|48<8<<KM_48>2@8?2A523[08;8>8<<r45348:897B888<<52G5148<8<<r4M_@\x1912@8?2C523V08;8>8<<K5348:89888<<GG5148<8<<KM_@\xea12@8?2D523e08;8>8<<K534702E888<<G8>2FC70r3@30EM515148<8<<KM_@\xac12@8?2G523\\08;8>8<<r4534702E7B888<<52515148<8<<r4M_@w12@8?2H523\xb808;8>8<<r88>2IC70r4@30EM534702E7B888<<52512J5248<8<<r4M_4702E7B888<<52515148<8<<r4M_48>2ICY0702J514702E7B888<<52512J5248<8<<r4M_@30q@\xe608?2Kc3^08;8>8<<r4534702E7B888<<52512J5248<8<<r4M_@\xb202@8?2L523b08;8>8<<r2534702M7N8<<7O888<<52M515248<8<<r2M_@w02@8?2P523b08;8>8<<r4534702M7N8<<7B888<<52M515248<8<<r4M_@<08;8>8<<E53^1^1@\xd0-:" #(princ
   " > " " // PC" newline void fn-disasm #fn(fn-code)
   #fn(fn-vals) #1# #fn("n10\\3F00[JA070504710qAKM63:72061:" #(newline fn-disasm print) print-val)
   #fn("n370A3U0FEl23N071A72151523A0A182ML237023@4024751K~512602765:" #(princ >= 1- " >" "  " hex5
@@ -309,7 +311,7 @@
                                                                        #fn(str-length)) keyword->sym)
             keyword-arg? #fn("n10B;3904200<61:" #(#fn(keyword?)) keyword-arg?) lambda-vars
             #fn("n1Ib520852185>1_51485<00qq54422237405162:" #(#0#
-                                                              #fn("n40S;J5040R340D:0B3Z00<R3T082;J504833<0702112263:A<0=1828364:0B3\x8d00<B3\x870730<r2523?074051R360q@=070250<2615442774051513=0A<0=182D64:833<0702112863:A<0=1D8364:0B3>070290<26164:01C:07021162:7029026164:" #(error
+                                                              #fn("n40S;J5040R340D:0B3Z00<R3T082;J504833<0702112263:A<0=1828364:0B3\x9a00<B3\x940730<r252;J;04730<r3523?074051R360q@=070250<2615442774051513=0A<0=182D64:833<0702112863:A<0=1D8364:0B3>070290<26164:01C:07021162:7029026164:" #(error
   "compile error: invalid argument list " ": optional arguments must come after required" length=
   caar "compile error: invalid optional argument " " in list " #fn(keyword?)
   ": keyword arguments must come last." "compile error: invalid formal argument ") check-formals)
@@ -340,7 +342,7 @@
   def get-defined-vars #fn(nconc) #fn(map) list #fn("n1A<0F<62:")
   #fn("n10H3400:0<B3F02071051C<00<A<0=51P:F<0<92<52922223747585515292<52_493<85PA<0=51P:" #(def
   caar #fn(nconc) #fn(map) list get-defined-vars)) caar cdar) expand-body)
-  #fn("n20H3400:0<B3M00<=B3F070051A<71051152e2@400<F<0=152P:" #(caar cadar) expand-lambda-list)
+  #fn("n20H3400:0<B3R00<=B3K070051A<7105115272051PP@400<F<0=152P:" #(caar cadar cddar) expand-lambda-list)
   #fn("n10H3600e1:0<B3?070051A<0=51P:0<A<0=51P:" #(caar) l-vars)
   #fn("n20T7005171051A<0T5122237489521522225e1F<868:52e192<888:528764:" #(lastcdr cddr #fn(nconc)
                                                                           #fn(map) list λ) expand-lambda)
--- a/src/compiler.sl
+++ b/src/compiler.sl
@@ -542,7 +542,8 @@
                       o ": optional arguments must come after required")
                (check-formals (cdr l) o opt kw)))
           ((and (cons? l) (cons? (car l)))
-           (unless (and (length= (car l) 2)
+           (unless (and (or (length= (car l) 2)  ; default value
+                            (length= (car l) 3)) ; default value and "was set" var
                         (sym? (caar l)))
                    (error "compile error: invalid optional argument " (car l)
                           " in list " o))
@@ -569,6 +570,8 @@
   (when (cons? opta)
     (let ((nxt (make-label g)))
       (emit g 'brbound i)
+      (when (cddar opta)
+        (emit g 'dup))
       (emit g 'brnn nxt)
       (compile-in g (extend-env env (list-head vars i) NIL) NIL (cadar opta))
       (emit g 'seta i)
@@ -702,50 +705,57 @@
             (any-duplicates rest)))))
 
   ;; compile lambda expression, assuming defines already lowered
-  (let ((g     (make-code-emitter))
-        (args  (cadr f))
-        (atail (lastcdr (cadr f)))
-        (vars  (lambda:vars f))
-        (opta  (filter cons? (cadr f)))
-        (last  (lastcdr f)))
-    (let* ((name  (if (not last) 'λ last))
-           (nargs (if (atom? args) 0 (length args)))
-           (nreq  (- nargs (length opta)))
-           (kwa   (filter keyword-arg? opta))
-           (dupv  (any-duplicates vars)))
+  (let* ((g     (make-code-emitter))
+         (args  (cadr f))
+         (atail (lastcdr (cadr f)))
+         (vars  (lambda:vars f))
+         (opta  (filter cons? (cadr f)))
+         (suppl (map caddr (filter cddr opta)))
+         (last  (lastcdr f))
+         (name  (if (not last) 'λ last))
+         (nargs (if (atom? args) 0 (length args)))
+         (nreq  (- nargs (length opta)))
+         (kwa   (filter keyword-arg? opta))
+         (nkwa  (length kwa))
+         (dupv  (any-duplicates vars)))
 
-      (when dupv
-        (error "compile error: duplicate argument: " dupv))
+    (when dupv
+      (error "compile error: duplicate argument: " dupv))
 
-      ;; emit argument checking prologue
-      (when opta
-        (if (not kwa)
-            (emit g 'optargs nreq
-                  (if atail (- nargs) nargs))
-            (begin
-              (bcode:indexfor g (make-perfect-hash-table
-                                 (map cons
-                                      (map car kwa)
-                                      (iota (length kwa)))))
-              (emit g 'keyargs nreq (length kwa)
-                    (if atail (- nargs) nargs))))
-        (emit-optional-arg-inits g env opta vars nreq))
+    ;; emit argument checking prologue
+    (when opta
+      (if (not kwa)
+          (emit g 'optargs nreq
+                (if atail (- nargs) nargs))
+          (begin
+            (bcode:indexfor g (make-perfect-hash-table
+                                (map cons
+                                     (map car kwa)
+                                     (iota nkwa))))
+            (emit g 'keyargs nreq nkwa
+                  (if atail (- nargs) nargs)))))
 
-      (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))
-            (atail         (emit g 'vargc nargs))
-            ((not opta)    (emit g 'argc  nargs)))
+    (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))
+          (atail         (emit g 'vargc nargs))
+          ((not opta)    (emit g 'argc  nargs)))
 
-      (let ((newenv (extend-env env vars (complex-bindings (lambda:body f) vars))))
-        (box-vars g (car newenv))
-        ;; set initial stack pointer
-        (aset! g 4 (+ (length vars) 4))
-        ;; compile body and return
-        (compile-in g newenv T (lambda:body f))
-        (emit g 'ret)
-        (values (fn (encode-byte-code (bcode:code g))
-                    (const-to-idx-vec g)
-                    name)
-                (bcode:cenv g))))))
+    (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))]}
+      (box-vars g (car newenv))
+      ;; set initial stack pointer
+      (aset! g 4 (+ (length vars) 4 (length suppl)))
+      ;; compile body and return
+      (compile-in g newenv T (lambda:body f))
+      (emit g 'ret)
+      (values (fn (encode-byte-code (bcode:code g))
+                  (const-to-idx-vec g)
+                  name)
+              (bcode:cenv g)))))
 
 ;; disassembler
 
--- a/src/system.sl
+++ b/src/system.sl
@@ -1290,7 +1290,9 @@
     (if (atom? l)
         l
         (cons (if (and (cons? (car l)) (cons? (cdr (car l))))
-                  (list (caar l) (expand-in (cadar l) env))
+                  (cons (caar l)
+                        (cons (expand-in (cadar l) env)
+                              (cddar l)))
                   (car l))
               (expand-lambda-list (cdr l) env))))