adding some combined instructions and teaching the compiler to emit them:

brn, brnn, brne, cadr

femtolisp/compiler.lsp

@@ -25,6 +25,7 @@
 	  :closure :argc :vargc :trycatch :copyenv :let :for :tapply
 	  :add2 :sub2 :neg :largc :lvargc
 	  :loada0 :loada1 :loadc00 :loadc01 :call.l :tcall.l
+	  :brne :brne.l :cadr :brnn :brnn.l :brn :brn.l
 	  
 	  dummy_t dummy_f dummy_nil]))
     (for 0 (1- (length keys))
@@ -62,7 +63,10 @@
 		      (aset! b 2 (+ nconst 1)))))))
 (define (emit e inst . args)
   (if (null? args)
-      (aset! e 0 (cons inst (aref e 0)))
+      (if (and (eq? inst :car) (pair? (aref e 0))
+	       (eq? (car (aref e 0)) :cdr))
+	  (set-car! (aref e 0) :cadr)
+	  (aset! e 0 (cons inst (aref e 0))))
       (begin
 	(if (memq inst '(:loadv :loadg :setg))
 	    (set! args (list (bcode:indexfor e (car args)))))
@@ -92,7 +96,23 @@
 		  ((equal? args '(0 1))
 		   (set! inst :loadc01)
 		   (set! args ()))))
-	(aset! e 0 (nreconc (cons inst args) (aref e 0)))))
+
+	(let ((lasti (if (pair? (aref e 0))
+			 (car (aref e 0)) ()))
+	      (bc (aref e 0)))
+	  (cond ((and (eq? inst :brf) (eq? lasti :not)
+		      (eq? (cadr bc) :null?))
+		 (aset! e 0 (cons (car args) (cons :brn (cddr bc)))))
+		((and (eq? inst :brf) (eq? lasti :not))
+		 (aset! e 0 (cons (car args) (cons :brt (cdr bc)))))
+		((and (eq? inst :brf) (eq? lasti :eq?))
+		 (aset! e 0 (cons (car args) (cons :brne (cdr bc)))))
+		((and (eq? inst :brf) (eq? lasti :null?))
+		 (aset! e 0 (cons (car args) (cons :brnn (cdr bc)))))
+		((and (eq? inst :brt) (eq? lasti :null?))
+		 (aset! e 0 (cons (car args) (cons :brn (cdr bc)))))
+		(else
+		 (aset! e 0 (nreconc (cons inst args) bc)))))))
   e)
 
 (define (make-label e)   (gensym))
@@ -134,14 +154,17 @@
 			   (get Instructions
 				(if long?
 				    (case vi
-				      (:jmp :jmp.l)
+				      (:jmp  :jmp.l)
-				      (:brt :brt.l)
+				      (:brt  :brt.l)
-				      (:brf :brf.l)
+				      (:brf  :brf.l)
+				      (:brne :brne.l)
+				      (:brnn :brnn.l)
+				      (:brn  :brn.l)
 				      (else vi))
 				    vi))))
 		(set! i (+ i 1))
 		(set! nxt (if (< i n) (aref v i) #f))
-		(cond ((memq vi '(:jmp :brf :brt))
+		(cond ((memq vi '(:jmp :brf :brt :brne :brnn :brn))
 		       (put! fixup-to-label (sizeof bcode) nxt)
 		       (io.write bcode ((if long? int32 int16) 0))
 		       (set! i (+ i 1)))
@@ -400,12 +423,19 @@
 		   (emit g (if tail? :tcall.l :call.l) nargs)))
 	  (let ((b (and (builtin? head)
 			(builtin->instruction head))))
-	    (if (not b)
+	    (if (and (eq? head 'cadr)
-		(compile-in g env #f head))
+		     (not (in-env? head env))
-	    (let ((nargs (compile-arglist g env (cdr x))))
+		     (equal? (top-level-value 'cadr) cadr)
-	      (if b
+		     (length= x 2))
-		  (compile-builtin-call g env tail? x head b nargs)
+		(begin (compile-in g env #f (cadr x))
-		  (emit g (if tail? :tcall :call) nargs))))))))
+		       (emit g :cadr))
+		(begin
+		  (if (not b)
+		      (compile-in g env #f head))
+		  (let ((nargs (compile-arglist g env (cdr x))))
+		    (if b
+			(compile-builtin-call g env tail? x head b nargs)
+			(emit g (if tail? :tcall :call) nargs))))))))))
 
 (define (expand-define form body)
   (if (symbol? form)
@@ -590,11 +620,11 @@
 		  (princ (number->string (ref-int32-LE code i)))
 		  (set! i (+ i 4)))
 		 
-		 ((:jmp :brf :brt)
+		 ((:jmp :brf :brt :brne :brnn :brn)
 		  (princ "@" (hex5 (+ i -4 (ref-int16-LE code i))))
 		  (set! i (+ i 2)))
 		 
-		 ((:jmp.l :brf.l :brt.l)
+		 ((:jmp.l :brf.l :brt.l :brne.l :brnn.l :brn.l)
 		  (princ "@" (hex5 (+ i -4 (ref-int32-LE code i))))
 		  (set! i (+ i 4)))
 		 

femtolisp/flisp.c

@@ -1062,6 +1062,36 @@ static value_t apply_cl(uint32_t nargs)
             if (v != FL_F) ip += (ptrint_t)GET_INT32(ip);
             else ip += 4;
             NEXT_OP;
+        OP(OP_BRNE)
+            if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT16(ip);
+            else ip += 2;
+            POPN(2);
+            NEXT_OP;
+        OP(OP_BRNEL)
+            if (Stack[SP-2] != Stack[SP-1]) ip += (ptrint_t)GET_INT32(ip);
+            else ip += 4;
+            POPN(2);
+            NEXT_OP;
+        OP(OP_BRNN)
+            v = POP();
+            if (v != NIL) ip += (ptrint_t)GET_INT16(ip);
+            else ip += 2;
+            NEXT_OP;
+        OP(OP_BRNNL)
+            v = POP();
+            if (v != NIL) ip += (ptrint_t)GET_INT32(ip);
+            else ip += 4;
+            NEXT_OP;
+        OP(OP_BRN)
+            v = POP();
+            if (v == NIL) ip += (ptrint_t)GET_INT16(ip);
+            else ip += 2;
+            NEXT_OP;
+        OP(OP_BRNL)
+            v = POP();
+            if (v == NIL) ip += (ptrint_t)GET_INT32(ip);
+            else ip += 4;
+            NEXT_OP;
         OP(OP_RET)
             v = POP();
             SP = curr_frame;
@@ -1152,6 +1182,13 @@ static value_t apply_cl(uint32_t nargs)
             if (!iscons(v)) type_error("cdr", "cons", v);
             Stack[SP-1] = cdr_(v);
             NEXT_OP;
+        OP(OP_CADR)
+            v = Stack[SP-1];
+            if (!iscons(v)) type_error("cdr", "cons", v);
+            v = cdr_(v);
+            if (!iscons(v)) type_error("car", "cons", v);
+            Stack[SP-1] = car_(v);
+            NEXT_OP;
         OP(OP_SETCAR)
             car(Stack[SP-2]) = Stack[SP-1];
             POPN(1); NEXT_OP;

femtolisp/opcodes.h

@@ -26,6 +26,7 @@ enum {
     OP_CLOSURE, OP_ARGC, OP_VARGC, OP_TRYCATCH, OP_COPYENV, OP_LET, OP_FOR,
     OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
     OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
+    OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
 
     OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
 
@@ -67,7 +68,8 @@ enum {
     &&L_OP_TAPPLY, &&L_OP_ADD2, &&L_OP_SUB2, &&L_OP_NEG, &&L_OP_LARGC,  \
     &&L_OP_LVARGC,                                                      \
     &&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01,       \
-    &&L_OP_CALLL, &&L_OP_TCALLL                                         \
+    &&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
+    &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL                  \
     }
 
 #define VM_APPLY_LABELS                                                 \

femtolisp/todo

@@ -1053,9 +1053,17 @@ new evaluator todo:
 - opcodes CAAR, CADR, CDAR, CDDR
 - EQTO N, compare directly to stored datum N
 - peephole opt
+  done:
+  not brf => brt
+  eq brf => brne
+  null brf => brnn
+  null brt => brn
+  null not brf => brn
+  cdr car => cadr
+
+  not yet:
+  not brt => brf
   constant+pop => nothing, e.g. 2-arg 'if' in statement position
-  not+brf => brt
-  not+brt => brf
   loadt+brf => nothing
   loadf+brt => nothing
   loadt+brt => jmp