shithub: femtolisp

Info  •  Files  •  Log  •  Branches

c***r: return empty list if passed empty list

--- a/README.md

+++ b/README.md

@@ -18,6 +18,7 @@

  * `[` and `]`, `{` and `}` are synonyms to `(` and `)`

  * `λ` as a shorthand for `lambda`

  * some of the previously available (but not merged) patches from the community and [Julia](https://github.com/JuliaLang/julia) are applied

+ * `c***r` of empty list returns empty list

  * "boot" image is built into the executable

  * vm opcode definitions and tables are generated from a single file

  * fixed bootstrap (makes it work properly when opcodes change)

--- a/compiler.lsp

+++ b/compiler.lsp

@@ -23,7 +23,7 @@

 (define (emit e inst . args)

   (let ((bc (aref e 0)))

     (if (null? args)

-        (if (and (eq? inst 'car) (pair? bc)

+        (if (and (eq? inst 'car)

                  (eq? (car bc) 'cdr))

             (set-car! bc 'cadr)

             (aset! e 0 (cons inst bc)))

@@ -55,8 +55,7 @@

                      (set! inst 'loadc1)

                      (set! args ()))))

-          (let ((lasti (if (pair? bc)

-                           (car bc) ())))

+          (let ((lasti (car bc)))

             (cond ((and (eq? inst 'brf)

                         (cond ((and (eq? lasti 'not)

                                     (eq? (cadr bc) 'null?))

@@ -312,8 +311,6 @@

 (define (1arg-lambda? func)

   (and (pair? func)

        (is-lambda? (car func))

-       (pair? (cdr func))

-       (pair? (cadr func))

        (length= (cadr func) 1)))

 (define (compile-short-circuit g env tail? forms default branch outl)

@@ -445,7 +442,8 @@

                      (length= x 2))

                 (begin (compile-in g env #f (cadr x))

                        (emit g 'cadr))

-                (if (and (pair? head) (is-lambda? (car head))

+                (if (and (pair? head)

+                         (is-lambda? (car head))

                          (inlineable? x))

                     (compile-let g env tail? x)

                     (begin

--- a/flisp.boot

+++ b/flisp.boot

@@ -45,7 +45,7 @@

   let λ prog1 trycatch begin raise))  throw #fn("9000n220212223e201e4e2:" #(raise

   list quote thrown-value))  quasiquote #fn("7000n1700E62:" #(bq-process)))

 	    1+ #fn("6000n10KM:" #() 1+) 1-

-	    #fn("6000n10K~:" #() 1-) 1arg-lambda? #fn("7000n10B;3U04700<51;3J040=B;3B040TB;3:04710TK62:" #(is-lambda?

+	    #fn("6000n10K~:" #() 1-) 1arg-lambda? #fn("7000n10B;3E04700<51;3:04710TK62:" #(is-lambda?

   length=) 1arg-lambda?)

 	    <= #fn("6000n210L;IB0470051;380470151S:" #(nan?) <=) >

 	    #fn("6000n210L:" #() >) >= #fn("6000n201L;IB0470051;380470151S:" #(nan?) >=)

@@ -201,7 +201,7 @@

   keyargs " " brbound (jmp brf brt brne brnn brn) "@" hex5 ref-int16-LE (jmp.l

   brf.l brt.l brne.l brnn.l brn.l)) disassemble)

 	    div #fn("7000n201k0EL;3C041EL;3404K;I504r/;I404EM:" #() div) emit

-	    #fn("P000z20EG82JX0120CH087B3B087<21C:08722_@900E187Pp@\xa8123124523A075082<52e1?2@30D42612752883F07882<29523:088T?1@30D^142612:52883F07882<29523:088T?1@30D^1412;C\\0822<d3=02=?14q?2@F0822>d3=02??14q?2@30O@30D412@C\\0822<d3=02A?14q?2@F0822>d3=02B?14q?2@30O@30D487B38087<@30q12CQ;3\x9b04882DCM087T2ECE00E82<2F7G8751PPp@x0882DCB00E82<2H87=PPp@a0882ICB00E82<2J87=PPp@J0882ECB00E82<2K87=PPp@30O;I]0412HCI0882ECB00E82<2F87=PPp@?00E7L182P8752p^140:" #(car

+	    #fn("O000z20EG82JR0120CB087<21C:08722_@900E187Pp@\x9e123124523A075082<52e1?2@30D42612752883F07882<29523:088T?1@30D^142612:52883F07882<29523:088T?1@30D^1412;C\\0822<d3=02=?14q?2@F0822>d3=02??14q?2@30O@30D412@C\\0822<d3=02A?14q?2@F0822>d3=02B?14q?2@30O@30D487<12CQ;3\x9b04882DCM087T2ECE00E82<2F7G8751PPp@x0882DCB00E82<2H87=PPp@a0882ICB00E82<2J87=PPp@J0882ECB00E82<2K87=PPp@30O;I]0412HCI0882ECB00E82<2F87=PPp@?00E7L182P8752p^140:" #(car

   cdr cadr #fn(memq) (loadv loadg setg) bcode:indexfor #fn(assq)

   ((loadv loadv.l) (loadg loadg.l) (setg setg.l) (loada loada.l) (seta seta.l)

 		   (box box.l)) > 255 ((loadc loadc.l)) loada (0) loada0 (1)

--- a/flisp.c

+++ b/flisp.c

@@ -1167,20 +1167,24 @@

 		OP(OP_CAR)

 			v = FL(stack)[FL(sp)-1];

-			if(__unlikely(!iscons(v))){

+			if(__likely(iscons(v)))

+				v = car_(v);

+			else if(__unlikely(v != FL(Nil))){

 				FL(stack)[ipd] = (uintptr_t)ip;

 				type_error("cons", v);

 			}

-			FL(stack)[FL(sp)-1] = car_(v);

+			FL(stack)[FL(sp)-1] = v;

 			NEXT_OP;

 		OP(OP_CDR)

 			v = FL(stack)[FL(sp)-1];

-			if(__unlikely(!iscons(v))){

+			if(__likely(iscons(v)))

+				v = cdr_(v);

+			else if(__unlikely(v != FL(Nil))){

 				FL(stack)[ipd] = (uintptr_t)ip;

 				type_error("cons", v);

 			}

-			FL(stack)[FL(sp)-1] = cdr_(v);

+			FL(stack)[FL(sp)-1] = v;

 			NEXT_OP;

 		OP(OP_CLOSURE)

@@ -1358,16 +1362,20 @@

 		OP(OP_CADR)

 			v = FL(stack)[FL(sp)-1];

-			if(__unlikely(!iscons(v))){

-				FL(stack)[ipd] = (uintptr_t)ip;

-				type_error("cons", v);

+			if(__likely(iscons(v))){

+				v = cdr_(v);

+				if(__likely(iscons(v)))

+					v = car_(v);

+				else

+					goto cadr_nil;

+			}else{

+			cadr_nil:

+				if(__unlikely(v != FL(Nil))){

+					FL(stack)[ipd] = (uintptr_t)ip;

+					type_error("cons", v);

+				}

 			}

-			v = cdr_(v);

-			if(__unlikely(!iscons(v))){

-				FL(stack)[ipd] = (uintptr_t)ip;

-				type_error("cons", v);

-			}

-			FL(stack)[FL(sp)-1] = car_(v);

+			FL(stack)[FL(sp)-1] = v;

 			NEXT_OP;

 		OP(OP_NEG)

--- a/test/unittest.lsp

+++ b/test/unittest.lsp

@@ -385,6 +385,14 @@

 (assert (equal? (bound? 'abc) #f))

 (assert-fail (eval '(+ abc 1)))

+;; c***r of empty list

+(assert (null? (car '())))

+(assert (null? (cdr '())))

+(assert (null? (cadr '())))

+(assert (null? (cdar '())))

+(assert (null? (caaar '())))

+(assert (null? (cdddr '())))

+

 ;; make many initialized tables large enough not to be stored in-line

 (for 1 100 (λ (i)

   (table eq?      2      eqv?     2