More PowerPC work

library/assoc.factor

@@ -12,19 +12,15 @@ IN: lists USING: kernel ;
 
 : assoc* ( key alist -- [[ key value ]] )
     #! Look up a key/value pair.
-    [ car = ] some-with?  dup [ car ] when ;
+    [ car = ] some-with?  car ;
 
-: assoc ( key alist -- value )
+: assoc ( key alist -- value ) assoc* cdr ;
-    #! Look up a value.
-    assoc*  dup [ cdr ] when ;
 
 : assq* ( key alist -- [[ key value ]] )
     #! Looks up a key/value pair using identity comparison.
-    [ car eq? ] some-with?  dup [ car ] when ;
+    [ car eq? ] some-with?  car ;
 
-: assq ( key alist -- value )
+: assq ( key alist -- value ) assq* cdr ;
-    #! Looks up a key/value pair using identity comparison.
-    assq*  dup [ cdr ] when ;
 
 : remove-assoc ( key alist -- alist )
     #! Remove all key/value pairs with this key.

library/compiler/generator.factor

@@ -65,10 +65,6 @@ DEFER: compile-jump-label ( label -- )
     compile-call
 ] "generator" set-word-prop
 
-#jump [
-    dup postpone-word  compile-jump-label
-] "generator" set-word-prop
-
 #call-label [
     compile-call-label
 ] "generator" set-word-prop

library/compiler/ppc/assembler.factor

@@ -30,15 +30,20 @@ USING: errors kernel math memory words ;
 : BL 0 1 i-form 18 insn ;
 : B 0 0 i-form 18 insn ;
 : BC 0 0 b-form 16 insn ;
+: BEQ 12 2 rot BC ;
 : BNE 4 2 rot BC ;
 : BCLR 0 8 0 0 b-form 19 insn ;
 : BLR 20 BCLR ;
 : BCLRL 0 8 0 1 b-form 19 insn ;
 : BLRL 20 BCLRL ;
+: BCCTR 0 264 0 0 b-form 19 insn ;
+: BCTR 20 BCCTR ;
 : MFSPR 5 shift 339 xfx-form 31 insn ;
 : MFLR 8 MFSPR ;
+: MFCTR 9 MFSPR ;
 : MTSPR 5 shift 467 xfx-form 31 insn ;
 : MTLR 8 MTSPR ;
+: MTCTR 9 MTSPR ;
 : LWZ d-form 32 insn ;
 : STW d-form 36 insn ;
 : STWU d-form 37 insn ;

library/compiler/ppc/generator.factor

@@ -22,6 +22,10 @@ USING: assembler inference kernel math words ;
 
 #epilogue [ drop compile-epilogue ] "generator" set-word-prop
 
+! #return-to [
+!     
+! ] "generator" set-word-prop
+
 #return [ drop BLR ] "generator" set-word-prop
 
 ! Far calls are made to addresses already known when the
@@ -39,10 +43,28 @@ USING: assembler inference kernel math words ;
         0 BL relative-24
     ] ifte ;
 
+: compile-jump-far ( n -- )
+    19 LOAD
+    19 MTCTR
+    BCTR ;
+
 : compile-jump-label ( label -- )
-    compile-epilogue  0 B relative-24 ;
+    dup primitive? [
+        word-xt compile-jump-far
+    ] [
+        0 B relative-24
+    ] ifte ;
+
+#jump [
+    dup postpone-word  compile-epilogue  compile-jump-label
+] "generator" set-word-prop
 
 : compile-jump-t ( label -- )
     POP-DS
     0 18 3 CMPI
     0 BNE  relative-14 ;
+
+: compile-jump-f ( label -- )
+    POP-DS
+    0 18 3 CMPI
+    0 BEQ  relative-14 ;

library/compiler/x86/generator.factor

@@ -17,6 +17,10 @@ math memory namespaces words ;
 : compile-call-label ( label -- ) 0 CALL relative ;
 : compile-jump-label ( label -- ) 0 JMP relative ;
 
+#jump [
+    dup postpone-word  compile-jump-label
+] "generator" set-word-prop
+
 : compile-target ( word -- ) 0 compile-cell absolute ;
 
 : compile-jump-t ( word -- )

library/compiler/xt.factor

@@ -121,7 +121,7 @@ C: relative-bitfld ( word mask -- )
     #! Check that the address can fit in a 24-bit wide address
     #! field, used by PowerPC instructions.
     dup relative-fixup dup rot relative-bitfld-mask bitand = [
-        "Cannot jump further than 64 megabytes" throw
+        "Cannot jump this far" throw
     ] unless ;
 
 M: relative-bitfld fixup

library/cons.factor

@@ -8,6 +8,11 @@ IN: lists USING: generic kernel kernel-internals ;
 
 BUILTIN: cons 2 [ 0 "car" f ] [ 1 "cdr" f ] ;
 
+! We borrow an idiom from Common Lisp. The car/cdr of an empty
+! list is the empty list.
+M: f car ;
+M: f cdr ;
+
 : swons ( cdr car -- [[ car cdr ]] )
     #! Push a new cons cell. If the cdr is f or a proper list,
     #! has the effect of prepending the car to the cdr.

library/hashtables.factor

@@ -52,10 +52,7 @@ IN: hashtables
     #! Look up a value in the hashtable.
     2dup (hashcode) swap hash-bucket assoc* ;
 
-: hash ( key table -- value )
+: hash ( key table -- value ) hash* cdr ;
-    #! Unlike hash*, this word cannot distinglish between an
-    #! undefined value, or a value set to f.
-    hash* dup [ cdr ] when ;
 
 : set-hash* ( key hash quot -- )
     #! Apply the quotation to yield a new association list.

library/io/files.factor

@@ -7,7 +7,7 @@ streams strings unparser ;
 ! Words for accessing filesystem meta-data.
 
 : exists? ( file -- ? ) stat >boolean ;
-: directory? ( file -- ? ) stat dup [ car ] when ;
+: directory? ( file -- ? ) stat car ;
 : directory ( dir -- list ) (directory) [ string> ] sort ;
 : file-length ( file -- length ) stat dup [ cdr cdr car ] when ;
 : file-extension ( filename -- extension )

library/test/inference.factor

@@ -217,8 +217,7 @@ SYMBOL: sym-test
 [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
 [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
 [ [ [ object ] [ general-t ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test
-[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
+[ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
-[ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
 
 ! [ [ 5 car ] infer ] unit-test-fails
 

library/test/lists/cons.factor

@@ -2,6 +2,9 @@ IN: scratchpad
 USE: lists
 USE: test
 
+[ f ] [ f car ] unit-test
+[ f ] [ f cdr ] unit-test
+
 [ 5 car ] unit-test-fails
 [ "Hello world" cdr ] unit-test-fails