more work on assembler

library/compiler/assembly-x86.factor

@@ -30,6 +30,7 @@ USE: kernel
 USE: compiler
 USE: math
 USE: stack
+USE: combinators
 
 : EAX 0 ;
 : ECX 1 ;
@@ -48,16 +49,31 @@ USE: stack
 
 : I>R ( imm reg -- )
     #! MOV <imm> TO <reg>
-    HEX: b8 + compile-byte  compile-cell ;
+    dup EAX = [
+        drop HEX: b8 compile-byte
+    ] [
+        HEX: 8b compile-byte
+        3 shift BIN: 101 bitor compile-byte
+    ] ifte compile-cell ;
 
 : [I]>R ( imm reg -- )
     #! MOV INDIRECT <imm> TO <reg>
-    HEX: a1 + compile-byte  compile-cell ;
+    dup EAX = [
+        drop HEX: a1 compile-byte
+    ] [
+        HEX: 8d compile-byte
+        3 shift BIN: 101 bitor compile-byte
+    ] ifte compile-cell ;
 
 : I>[R] ( imm reg -- )
     #! MOV <imm> TO INDIRECT <reg>
     HEX: c7 compile-byte  compile-byte  compile-cell ;
 
+: R>[I] ( reg imm -- )
+    #! MOV INDIRECT <imm> TO <reg>.
+    #! Actually only works with EAX (?)
+    swap HEX: a3 + compile-byte  compile-cell ;
+
 : [R]>R ( reg reg -- )
     #! MOV INDIRECT <reg> TO <reg>.
     HEX: 8b compile-byte  swap 3 shift bitor compile-byte ;
@@ -91,16 +107,26 @@ USE: stack
     4 DATASTACK I+[I]
     ECX POP ;
 
-: (JMP) ( xt opcode -- )
+: POP-DS ( -- )
+    #! Pop datastack into EAX.
+    ( ECX PUSH )
+    DATASTACK ECX I>R
+    ! LEA...
+    HEX: 8d compile-byte HEX: 41 compile-byte HEX: fc compile-byte
+    EAX DATASTACK R>[I]
+    EAX EAX [R]>R
+    ( ECX POP ) ;
+
+: (JUMP) ( xt opcode -- )
     #! JMP, CALL insn is 5 bytes long
     #! addr is relative to *after* insn
     compile-byte  compiled-offset 4 + - compile-cell ;
 
-: JMP ( -- )
+: JUMP ( -- )
-    HEX: e9 (JMP) ;
+    HEX: e9 (JUMP) ;
 
 : CALL ( -- )
-    HEX: e8 (JMP) ;
+    HEX: e8 (JUMP) ;
 
 : RET ( -- )
     HEX: c3 compile-byte ;

library/compiler/compiler.factor

@@ -39,9 +39,8 @@ USE: logic
 USE: kernel
 USE: vectors
 
-: compile-word ( word -- )
+: pop-literal ( -- obj )
-    #! Compile a JMP at the end (tail call optimization)
+    "compile-datastack" get vector-pop ;
-    word-xt "compile-last" get [ JMP ] [ CALL ] ifte ;
 
 : compile-literal ( obj -- )
     dup fixnum? [
@@ -55,11 +54,27 @@ USE: vectors
     0 swap set-vector-length ;
 
 : postpone ( obj -- )
+    #! Literals are not compiled immediately, so that words like
+    #! ifte with special compilation behavior can work.
     "compile-datastack" get vector-push ;
 
+: compile-simple-word ( word -- )
+    #! Compile a JMP at the end (tail call optimization)
+    commit-literals word-xt
+    "compile-last" get [ JUMP ] [ CALL ] ifte ;
+
+: compile-word ( word -- )
+    #! If a word has a compiling property, then it has special
+    #! compilation behavior.
+    "compiling" over word-property dup [
+        nip call
+    ] [
+        drop compile-simple-word
+    ] ifte ;
+
 : compile-atom ( obj -- )
     [
-        [ word? ] [ commit-literals compile-word ]
+        [ word? ] [ compile-word ]
         [ drop t ] [ postpone ]
     ] cond ;
 

native/error.c

@@ -15,6 +15,8 @@ void critical_error(char* msg, CELL tagged)
 
 void fix_stacks(void)
 {
+	fprintf(stderr,"%x\n",ds);
+	fprintf(stderr,"%x\n",ds_bot);
 	if(STACK_UNDERFLOW(ds,ds_bot)
 		|| STACK_OVERFLOW(ds,ds_bot))
 		reset_datastack();