From 54e06729fb6c09f61118c288242a50be45c680a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 19 Mar 2005 05:30:49 +0000 Subject: [PATCH] More PowerPC work --- library/assoc.factor | 12 ++++-------- library/compiler/generator.factor | 4 ---- library/compiler/ppc/assembler.factor | 5 +++++ library/compiler/ppc/generator.factor | 24 +++++++++++++++++++++++- library/compiler/x86/generator.factor | 4 ++++ library/compiler/xt.factor | 2 +- library/cons.factor | 5 +++++ library/hashtables.factor | 5 +---- library/io/files.factor | 2 +- library/test/inference.factor | 3 +-- library/test/lists/cons.factor | 3 +++ 11 files changed, 48 insertions(+), 21 deletions(-) diff --git a/library/assoc.factor b/library/assoc.factor index 9ac6cfacab..e9250d3400 100644 --- a/library/assoc.factor +++ b/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 ) - #! Look up a value. - assoc* dup [ cdr ] when ; +: assoc ( key alist -- value ) assoc* cdr ; : 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 ) - #! Looks up a key/value pair using identity comparison. - assq* dup [ cdr ] when ; +: assq ( key alist -- value ) assq* cdr ; : remove-assoc ( key alist -- alist ) #! Remove all key/value pairs with this key. diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 86ddaa023e..0f0cf4f8b0 100644 --- a/library/compiler/generator.factor +++ b/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 diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor index 0bf7a57eed..2a9578a6d7 100644 --- a/library/compiler/ppc/assembler.factor +++ b/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 ; diff --git a/library/compiler/ppc/generator.factor b/library/compiler/ppc/generator.factor index 4f6ab1c481..8a68de81a7 100644 --- a/library/compiler/ppc/generator.factor +++ b/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 ; diff --git a/library/compiler/x86/generator.factor b/library/compiler/x86/generator.factor index fd6e8b119c..438f795980 100644 --- a/library/compiler/x86/generator.factor +++ b/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 -- ) diff --git a/library/compiler/xt.factor b/library/compiler/xt.factor index dfd2dfa8bc..bac1a4506c 100644 --- a/library/compiler/xt.factor +++ b/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 diff --git a/library/cons.factor b/library/cons.factor index 9044e09feb..026fb05633 100644 --- a/library/cons.factor +++ b/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. diff --git a/library/hashtables.factor b/library/hashtables.factor index 1a5fb38dad..58cd4749c3 100644 --- a/library/hashtables.factor +++ b/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 ) - #! Unlike hash*, this word cannot distinglish between an - #! undefined value, or a value set to f. - hash* dup [ cdr ] when ; +: hash ( key table -- value ) hash* cdr ; : set-hash* ( key hash quot -- ) #! Apply the quotation to yield a new association list. diff --git a/library/io/files.factor b/library/io/files.factor index 05e65a7200..049087b4ce 100644 --- a/library/io/files.factor +++ b/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 ) diff --git a/library/test/inference.factor b/library/test/inference.factor index 4ec2dbb2e0..e028f79d22 100644 --- a/library/test/inference.factor +++ b/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 ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test +[ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test ! [ [ 5 car ] infer ] unit-test-fails diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor index f152daa4fb..284fb4e9df 100644 --- a/library/test/lists/cons.factor +++ b/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