minor cleanups all over the place

TODO.FACTOR.txt

@@ -1,5 +1,15 @@
 + 0.80:
 
+- -with combinators are ackward
+
+- cleanups:
+  alien/compiler
+  inference/shuffle
+  inference-words inline-block
+  io/buffer - use aliens not integers
+  alien/malloc - use aliens not integers
+  ui/line-editor - don't use variables
+- fix powerpc backend
 - <array> ( length initial )
 - <string> ( length initial )
 - remove repetitions
@@ -25,7 +35,6 @@ word help sections:
 parsing word sections:
 - syntax
 
-- malloc, free, realloc, memcpy: aliens
 - check 'see'
 - intrinsic char-slot set-char-slot for x86
 - closing ui does not stop timers

contrib/httpd/mime.factor

@@ -3,6 +3,9 @@
 IN: httpd
 USING: io hashtables kernel lists namespaces ;
 
+: file-extension ( filename -- extension )
+    "." split dup length 1 <= [ drop f ] [ peek ] if ;
+
 : mime-type ( filename -- mime-type )
     file-extension "mime-types" get
     hash [ "text/plain" ] unless* ;

contrib/math/utils.factor

@@ -36,6 +36,10 @@ USING: errors kernel sequences math sequences-internals namespaces arrays ;
     #! Complex inner product.
     0 [ ** + ] 2reduce ;
 
+: proj ( u v -- w )
+    #! Orthogonal projection of u onto v.
+    [ [ v. ] keep norm-sq v/n ] keep n*v ;
+
 : minmax ( seq -- min max )
     #! find the min and max of a seq in one pass
     inf -inf rot [ dup pick max -rot nip pick min -rot nip ] each ;

library/alien/aliens.factor

@@ -15,8 +15,7 @@ M: alien = ( obj obj -- ? )
         2drop f
     ] if ;
 
-: library ( name -- object )
+: library ( name -- object ) "libraries" get hash ;
-    dup [ "libraries" get hash ] when ;
 
 : load-library ( name -- dll )
     #! Higher level wrapper around dlopen primitive.

library/alien/c-types.factor

@@ -18,24 +18,22 @@ sequences sequences-internals strings words ;
 SYMBOL: c-types
 
 : c-type ( name -- type )
-    dup c-types get hash [ ] [
+    dup c-types get hash
-        "No such C type: " swap append throw f
+    [ ] [ "No such C type: " swap append throw ] ?if ;
-    ] ?if ;
 
-: c-size ( name -- size )
+: c-size ( name -- size ) "width" swap c-type hash ;
-    "width" swap c-type hash ;
 
-: c-getter ( name -- quot )
+: c-getter ( name -- quot ) "getter" swap c-type hash ;
-    "getter" swap c-type hash ;
 
-: c-setter ( name -- quot )
+: c-setter ( name -- quot ) "setter" swap c-type hash ;
-    "setter" swap c-type hash ;
 
 : define-c-type ( quot name -- )
     >r <c-type> [ swap bind ] keep r> c-types get set-hash ;
     inline
 
-: <c-object> ( size -- c-ptr ) cell / ceiling <byte-array> ;
+: bytes>cells cell / ceiling ;
+
+: <c-object> ( size -- c-ptr ) bytes>cells <byte-array> ;
 
 : define-pointer ( type -- )
     "void*" c-type swap "*" append c-types get set-hash ;

library/bootstrap/primitives.factor

@@ -18,7 +18,7 @@ words ;
 "syntax" vocab
 
 H{ } clone vocabularies set
-f crossref set
+crossref off
 
 vocabularies get [ "syntax" set [ reveal ] each ] bind
 

library/collections/arrays.factor

@@ -12,7 +12,7 @@ USING: kernel math math-internals sequences sequences-internals ;
         ] all? 2nip
     ] [
         2drop f
-    ] if ; flushable
+    ] if ; inline
 
 IN: arrays
 

library/collections/sequence-eq.factor

@@ -15,7 +15,7 @@ UNION: sequence array string sbuf vector ;
         dup length [ >r 2dup r> 2nth-unsafe = ] all? 2nip
     ] [
         2drop f
-    ] if ; flushable
+    ] if ; inline
 
 M: sequence = ( obj seq -- ? )
     2dup eq? [

library/collections/sequences.factor

@@ -6,10 +6,7 @@ USING: errors generic kernel math math-internals strings vectors ;
 ! This file is needed very early in bootstrap.
 
 ! Sequences support the following protocol. Concrete examples
-! are strings, string buffers, vectors, and arrays. Arrays are
+! are strings, string buffers, vectors, and arrays.
-! low level and no | quot: elt -- ? t bounds-checked; they are in the
-! kernel-internals vocabulary, so don't use them unless you have
-! a good reason.
 
 GENERIC: empty? ( sequence -- ? ) flushable
 GENERIC: length ( sequence -- n ) flushable

library/collections/strings-epilogue.factor

@@ -11,8 +11,7 @@ sequences strings ;
     <repeated> >string ; inline
 
 : padding ( string count char -- string )
-    >r swap length - dup 0 <= [ r> 2drop "" ] [ r> fill ] if ;
+    >r swap length - 0 max r> fill ; flushable
-    flushable
 
 : pad-left ( string count char -- string )
     pick >r padding r> append ; flushable
@@ -21,7 +20,7 @@ sequences strings ;
     pick >r padding r> swap append ; flushable
 
 : ch>string ( ch -- str )
-    1 <sbuf> [ push ] keep (sbuf>string) ; flushable
+    1 swap fill ; flushable
 
 : >sbuf ( seq -- sbuf )
     dup length <sbuf> [ swap nappend ] keep ; inline

library/compiler/amd64/alien.factor

@@ -0,0 +1,15 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler-backend
+USING: alien assembler compiler inference kernel
+kernel-internals lists math memory namespaces words ;
+
+M: %alien-invoke generate-node drop ;
+
+M: %parameter generate-node drop ;
+
+M: %unbox generate-node drop ;
+
+M: %box generate-node drop ;
+
+M: %cleanup generate-node drop ;

library/compiler/amd64/architecture.factor

@@ -17,6 +17,13 @@ USING: assembler compiler-backend kernel sequences ;
 
 : vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline
 
+: param-regs { R9 R8 RCX RDX RSI RDI } ;
+
+DEFER: compile-c-call
+
+: compile-c-call* ( symbol dll -- operands )
+    param-regs swap [ MOV ] 2each compile-c-call ;
+
 ! FIXME
 M: int-regs fastcall-regs drop 0 ;
 M: int-regs reg-class-size drop 4 ;

library/compiler/generator.factor

@@ -55,14 +55,8 @@ SYMBOL: previous-offset
 M: %label generate-node ( vop -- )
     vop-label save-xt ;
 
-M: %end-dispatch generate-node ( vop -- ) drop ;
+M: %target-label generate-node ( vop -- )
-
+    drop label 0 assemble-cell absolute-cell ;
-: compile-target ( word -- ) 0 assemble-cell absolute-cell ;
-
-M: %target-label generate-node vop-label compile-target ;
-
-M: %target generate-node
-    vop-label dup postpone-word  compile-target ;
 
 M: %parameters generate-node ( vop -- ) drop ;
 

library/compiler/linearizer.factor

@@ -77,8 +77,7 @@ M: #if linearize* ( node -- )
     in-1
     -1 %inc-d ,
     0 %dispatch ,
-    [ <label> dup %target-label ,  cons ] map
+    [ <label> dup %target-label ,  cons ] map ;
-    %end-dispatch , ;
 
 : dispatch-body ( label/param -- )
     [ uncons %label , linearize* ] each ;

library/compiler/vops.factor

@@ -147,14 +147,6 @@ TUPLE: %target-label ;
 C: %target-label make-vop ;
 : %target-label label-vop <%target-label> ;
 
-TUPLE: %target ;
-C: %target make-vop ;
-: %target label-vop <%target> ;
-
-TUPLE: %end-dispatch ;
-C: %end-dispatch make-vop ;
-: %end-dispatch empty-vop <%end-dispatch> ;
-
 ! stack operations
 TUPLE: %peek ;
 C: %peek make-vop ;

library/compiler/x86/architecture.factor

@@ -17,6 +17,12 @@ USING: assembler compiler-backend kernel sequences ;
 
 : vregs { EAX ECX EDX } ; inline
 
+DEFER: compile-c-call
+
+: compile-c-call* ( symbol dll args -- operands )
+    [ [ PUSH ] each compile-c-call ] keep
+    [ drop 0 scratch POP ] each ;
+
 ! On x86, parameters are never passed in registers.
 M: int-regs fastcall-regs drop 0 ;
 M: int-regs reg-class-size drop 4 ;

library/compiler/x86/fixnum.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-backend
-USING: assembler compiler errors kernel kernel-internals math
+USING: arrays assembler compiler errors kernel kernel-internals
-math-internals memory namespaces words ;
+math math-internals memory namespaces words ;
 
 : literal-overflow ( -- dest src )
     #! Called if the src operand is a literal.
@@ -25,11 +25,9 @@ math-internals memory namespaces words ;
     ! Compute a result, this time it will fit.
     r> execute
     ! Create a bignum.
-    0 output-operand PUSH
+    "s48_long_to_bignum" f 0 output-operand 1array compile-c-call*
-    "s48_long_to_bignum" f compile-c-call
     ! An untagged pointer to the bignum is now in EAX; tag it
     return-reg bignum-tag OR
-    0 scratch POP
     "end" get save-xt ; inline
 
 M: %fixnum+ generate-node ( vop -- )
@@ -46,20 +44,14 @@ M: %fixnum* generate-node ( vop -- )
     0 input-operand IMUL
     <label> "end" set
     "end" get JNO
-    remainder-reg PUSH
+    "s48_long_long_to_bignum" f
-    1 input-operand PUSH
+    remainder-reg 1 input-operand 2array compile-c-call*
-    "s48_long_long_to_bignum" f compile-c-call
-    0 scratch POP
-    0 scratch POP
     ! now we have to shift it by three bits to remove the second
     ! tag
-    tag-bits neg PUSH
+    "s48_bignum_arithmetic_shift" f
-    1 input-operand PUSH
+    tag-bits neg 1 input-operand 2array compile-c-call*
-    "s48_bignum_arithmetic_shift" f compile-c-call
     ! an untagged pointer to the bignum is now in EAX; tag it
     return-reg bignum-tag OR
-    0 scratch POP
-    0 scratch POP
     "end" get save-xt ;
 
 M: %fixnum-mod generate-node ( vop -- )
@@ -85,12 +77,10 @@ M: %fixnum-mod generate-node ( vop -- )
     "end" get JNO
     ! There was an overflow, so make ECX into a bignum. we must
     ! save EDX since its volatile.
-    remainder-reg PUSH
+    "s48_long_to_bignum" f
-    0 input-operand PUSH
+    remainder-reg 0 input-operand 2array compile-c-call*
-    "s48_long_to_bignum" f compile-c-call
     ! An untagged pointer to the bignum is now in EAX; tag it
     return-reg bignum-tag OR
-    0 input-operand POP
     ! the remainder is now in EDX
     remainder-reg POP
     "end" get save-xt ;
@@ -126,16 +116,12 @@ M: %fixnum<< generate-node
     "no-overflow" get JBE
     ! there is going to be an overflow, make a bignum
     1 input-operand tag-bits SAR
-    0 input PUSH
+    "s48_long_to_bignum" f
-    1 input-operand PUSH
+    0 input 1 input-operand 2array compile-c-call*
-    "s48_long_to_bignum" f compile-c-call
+    "s48_bignum_arithmetic_shift" f
-    0 scratch POP
+    1 input-operand 1array compile-c-call*
-    1 input-operand PUSH
-    "s48_bignum_arithmetic_shift" f compile-c-call
     ! tag the result
     1 input-operand bignum-tag OR
-    0 scratch POP
-    1 scratch POP
     "end" get JMP
     ! there is not going to be an overflow
     "no-overflow" get save-xt

library/compiler/x86/generator.factor

@@ -7,21 +7,21 @@ kernel-internals lists math memory namespaces sequences words ;
 ! Not used on x86
 M: %prologue generate-node drop ;
 
-: compile-dlsym ( symbol dll quot -- )
+: compile-c-call ( symbol dll -- )
-    >r 2dup dlsym r> call 1 0 rel-dlsym ; inline
+    2dup dlsym CALL 1 0 rel-dlsym ;
 
-: compile-c-call ( symbol dll -- ) [ CALL ] compile-dlsym ;
+: (call-label)
+    label dup postpone-word
+    dup primitive? [ address-operand ] when ;
 
 M: %call generate-node ( vop -- )
-    drop label dup postpone-word
+    drop (call-label) CALL ;
-    dup primitive? [ address-operand ] when CALL ;
 
 M: %call-label generate-node ( vop -- )
     drop label CALL ;
 
 M: %jump generate-node ( vop -- )
-    drop label dup postpone-word
+    drop (call-label) JMP ;
-    dup primitive? [ address-operand ] when JMP ;
 
 M: %jump-label generate-node ( vop -- )
     drop label JMP ;

library/compiler/x86/slots.factor

@@ -46,10 +46,12 @@ M: %fast-set-slot generate-node ( vop -- )
 
 M: %getenv generate-node ( vop -- )
     drop
-    0 output-operand 0 input userenv@ 1array MOV
+    0 output-operand 0 input userenv@ MOV
-    0 input 0 rel-userenv ;
+    0 input 0 rel-userenv
+    0 output-operand dup 1array MOV ;
 
 M: %setenv generate-node ( vop -- )
     drop
-    1 input userenv@ 1array 0 input-operand MOV
+    0 scratch 1 input userenv@ MOV
-    1 input 0 rel-userenv ;
+    1 input 0 rel-userenv
+    0 scratch 1array 0 input-operand MOV ;

library/generic/slots.factor

@@ -29,11 +29,8 @@ parser sequences strings words ;
 : define-slot ( class slot reader writer -- )
     >r >r 2dup r> define-reader r> define-writer ;
 
-: ?create ( { name vocab } -- word )
-    dup [ first2 create ] when ;
-
 : intern-slots ( spec -- spec )
-    [ first3 [ ?create ] 2apply 3array ] map ;
+    [ first3 [ dup [ first2 create ] when ] 2apply 3array ] map ;
 
 : define-slots ( class spec -- )
     #! Define a collection of slot readers and writers for the

library/inference/branches.factor

@@ -9,9 +9,6 @@ namespaces parser prettyprint sequences strings vectors words ;
     #! shorter, pad it with unknown results at the bottom.
     dup 0 [ length max ] reduce swap [ add-inputs ] map-with ;
 
-: unify-length ( seq seq -- seq )
-    2array unify-lengths first2 ;
-
 : unify-values ( seq -- value )
     #! If all values in list are equal, return the value.
     #! Otherwise, unify.

library/inference/call-optimizers.factor

@@ -118,14 +118,6 @@ SYMBOL: @
     { { @ 1 }  [ 2drop 0 ] }
 } define-identities
 
-! [ ^ ] {
-!     { { 1 @ }  [ 2drop 1 ]             }
-!     { { @ 1 }  [ drop ]                }
-!     { { @ 2 }  [ drop dup * ]          }
-!     { { @ -1 } [ drop 1 swap / ]       }
-!     { { @ -2 } [ drop dup * 1 swap / ] }
-! } define-identities
-
 [ bitand fixnum-bitand bignum-bitand ] {
     { { @ -1 } [ drop ] }
     { { -1 @ } [ nip  ] }

library/inference/split-nodes.factor

@@ -1,5 +1,5 @@
 IN: optimizer
-USING: inference kernel lists sequences words ;
+USING: arrays inference kernel lists sequences words ;
 
 ! #if --> X
 !   |
@@ -24,8 +24,10 @@ M: node split-node* ( node -- ) drop ;
 
 : post-inline ( #return/#values #call/#merge -- )
     dup [
-        [ >r node-in-d r> node-out-d unify-length ] keep
+        [
-        node-successor subst-values
+            >r node-in-d r> node-out-d
+            2array unify-lengths first2
+        ] keep node-successor subst-values
     ] [
         2drop
     ] if ;

library/io/files.factor

@@ -17,9 +17,6 @@ styles ;
 
 : file-length ( file -- length ) stat third ;
 
-: file-extension ( filename -- extension )
-    "." split dup length 1 <= [ drop f ] [ peek ] if ;
-
 : resource-path ( path -- path )
     "resource-path" get [ "." ] unless* swap path+ ;
 

library/math/arc-trig-hyp.factor

@@ -15,10 +15,10 @@ USING: kernel math math-internals ;
 : acosech recip asinh ; inline
 : atanh dup 1+ swap 1- neg / log 2 / ; inline
 : acoth recip atanh ; inline
-: <=1 ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline
+: [-1,1]? ( x -- ? ) dup complex? [ drop f ] [ abs 1 <= ] if ; inline
-: asin dup <=1 [ fasin ] [ i * asinh -i * ] if ; inline
+: asin dup [-1,1]? [ fasin ] [ i * asinh -i * ] if ; inline
-: acos dup <=1 [ facos ] [ asin pi 2 / swap - ] if ; inline
+: acos dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ; inline
-: atan dup <=1 [ fatan ] [ i * atanh i * ] if ; inline
+: atan dup [-1,1]? [ fatan ] [ i * atanh i * ] if ; inline
 : asec recip acos ; inline
 : acosec recip asin ; inline
 : acot recip atan ; inline

library/math/constants.factor

@@ -8,3 +8,4 @@ IN: math
 : -inf -1.0 0.0 / ; inline
 : e 2.7182818284590452354 ; inline
 : pi 3.14159265358979323846 ; inline
+: epsilon 2.2204460492503131e-16 ; inline

library/math/float.factor

@@ -24,5 +24,3 @@ M: float /f float/f ;
 
 M: float 1+ 1.0 float+ ;
 M: float 1- 1.0 float- ;
-
-: epsilon 2.2204460492503131e-16 ; inline

library/math/vectors.factor

@@ -37,7 +37,3 @@ USING: arrays generic kernel sequences ;
 : normalize ( vec -- uvec )
     #! Unit vector with same direction as vec.
     dup norm v/n ;
-
-: proj ( u v -- w )
-    #! Orthogonal projection of u onto v.
-    [ [ v. ] keep norm-sq v/n ] keep n*v ;

library/test/files.factor

@@ -1,8 +0,0 @@
-IN: temporary
-USE: io
-USE: lists
-USE: test
-
-[ "txt" ] [ "foo.txt" file-extension ] unit-test
-[ f ] [ "foobar" file-extension ] unit-test
-[ "txt" ] [ "foo.bar.txt" file-extension ] unit-test

library/test/test.factor

@@ -81,11 +81,9 @@ SYMBOL: failures
         "collections/hashtables" "collections/sbuf"
         "collections/strings" "collections/namespaces"
         "collections/vectors" "collections/sequences"
-        "collections/queues"
+        "collections/queues" "generic" "tuple" "parser"
-        "generic" "tuple" "files" "parser"
         "parse-number" "init" "io/io"
-        "words" "prettyprint" "random"
+        "words" "prettyprint" "random" "stream" "math/bitops"
-        "stream" "math/bitops"
         "math/math-combinators" "math/rational" "math/float"
         "math/complex" "math/irrational"
         "math/integer" "threads" "parsing-word"

library/unix/io.factor

@@ -13,11 +13,6 @@ USING: namespaces ;
 : byte-bit ( n alien -- byte bit )
     over -5 shift alien-unsigned-4 swap 31 bitand ;
 
-: bit-length ( n -- n ) cell / ceiling ;
-
-: <bit-array> ( n -- array )
-    bit-length <byte-array> ;
-
 : bit-nth ( n alien -- ? )
     byte-bit 1 swap shift bitand 0 > ;
 
@@ -29,7 +24,7 @@ USING: namespaces ;
     swap -5 shift set-alien-unsigned-4 ;
 
 : clear-bits ( alien len -- )
-    bit-length [ 0 -rot set-alien-unsigned-cell ] each-with ;
+    bytes>cells [ 0 -rot set-alien-unsigned-cell ] each-with ;
 
 ! Global variables
 SYMBOL: read-fdset
@@ -322,8 +317,8 @@ USE: io
     #! other time can have unintended consequences.
     global [
         H{ } clone read-tasks set
-        FD_SETSIZE <bit-array> read-fdset set
+        FD_SETSIZE <c-object> read-fdset set
         H{ } clone write-tasks set
-        FD_SETSIZE <bit-array> write-fdset set
+        FD_SETSIZE <c-object> write-fdset set
         0 1 t <fd-stream> stdio set
     ] bind ;

library/vocabularies.factor

@@ -47,7 +47,7 @@ SYMBOL: vocabularies
 : lookup ( name vocab -- word ) vocab ?hash ;
 
 : search ( name vocabs -- word )
-    [ lookup ] map-with [ ] find nip ;
+    dupd [ lookup ] find nip ?hash ;
 
 : reveal ( word -- )
     #! Add a new word to its vocabulary.