diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 41612e9952..9a57e8d13b 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -15,7 +15,7 @@ namespaces parser prettyprint sequences sequences-internals strings vectors words ; IN: image -( Constants ) +! Constants : image-magic HEX: 0f0e0d0c ; inline : image-version 2 ; inline @@ -87,26 +87,26 @@ SYMBOL: architecture : emit-object ( header tag quot -- addr ) swap here-as >r swap tag-header emit call align-here r> ; -( Image header ) +! Image header : header ( -- ) image-magic emit image-version emit - ( relocation base at end of header ) data-base emit - ( bootstrap quotation set later ) 0 emit - ( global namespace set later ) 0 emit - ( pointer to t object ) 0 emit - ( pointer to bignum 0 ) 0 emit - ( pointer to bignum 1 ) 0 emit - ( pointer to bignum -1 ) 0 emit - ( size of data heap set later ) 0 emit - ( size of code heap is 0 ) 0 emit - ( reloc base of code heap is 0 ) 0 emit ; + data-base emit ! relocation base at end of header + 0 emit ! bootstrap quotation set later + 0 emit ! global namespace set later + 0 emit ! pointer to t object + 0 emit ! pointer to bignum 0 + 0 emit ! pointer to bignum 1 + 0 emit ! pointer to bignum -1 + 0 emit ! size of data heap set later + 0 emit ! size of code heap is 0 + 0 emit ; ! reloc base of code heap is 0 GENERIC: ' ( obj -- ptr ) #! Write an object to the image. -( Bignums ) +! Bignums : bignum-bits bootstrap-cell-bits 2 - ; @@ -133,7 +133,7 @@ M: bignum ' #! This can only emit 0, -1 and 1. bignum-tag bignum-tag [ emit-bignum ] emit-object ; -( Fixnums ) +! Fixnums M: fixnum ' #! When generating a 32-bit image on a 64-bit system, @@ -141,14 +141,14 @@ M: fixnum ' dup most-negative-fixnum most-positive-fixnum between? [ fixnum-tag tag-address ] [ >bignum ' ] if ; -( Floats ) +! Floats M: float ' float-tag float-tag [ align-here double>bits emit-64 ] emit-object ; -( Special objects ) +! Special objects ! Padded with fixnums for 8-byte alignment @@ -162,13 +162,13 @@ M: f ' : 1, 1 >bignum ' 1-offset fixup ; : -1, -1 >bignum ' -1-offset fixup ; -( Beginning of the image ) +! Beginning of the image ! The image begins with the header, then T, ! and the bignums 0, 1, and -1. : begin-image ( -- ) header t, 0, 1, -1, ; -( Words ) +! Words : emit-word ( word -- ) [ @@ -199,12 +199,12 @@ M: f ' M: word ' ; -( Wrappers ) +! Wrappers M: wrapper ' wrapped ' wrapper-tag wrapper-tag [ emit ] emit-object ; -( Ratios and complexes ) +! Ratios and complexes : emit-pair [ [ emit ] 2apply ] emit-object ; @@ -215,7 +215,7 @@ M: ratio ' M: complex ' >rect [ ' ] 2apply complex-tag complex-tag emit-pair ; -( Strings ) +! Strings : emit-chars ( seq -- ) big-endian get [ [ ] map ] unless @@ -236,7 +236,7 @@ M: string ' #! to the image objects get [ emit-string ] cache ; -( Arrays and vectors ) +! Arrays and vectors : emit-array ( list type -- pointer ) >r [ ' ] map r> object-tag [ @@ -273,7 +273,7 @@ M: sbuf ' emit ( array ptr ) ] emit-object ; -( Hashes ) +! Hashes M: hashtable ' [ hash-array ' ] keep @@ -283,7 +283,7 @@ M: hashtable ' emit ( array ptr ) ] emit-object ; -( End of the image ) +! End of the image : words, ( -- ) all-words [ emit-word ] each ; @@ -315,7 +315,7 @@ M: hashtable ' "Object cache size: " write objects get hash-size . \ word global remove-hash ; -( Image output ) +! Image output : (write-image) ( image -- ) bootstrap-cell swap big-endian get [ diff --git a/library/collections/hashtables.factor b/library/collections/hashtables.factor index db9a59181f..7238b80a99 100644 --- a/library/collections/hashtables.factor +++ b/library/collections/hashtables.factor @@ -249,7 +249,7 @@ M: hashtable hashcode : ?hash ( key hash/f -- value/f ) dup [ hash ] [ 2drop f ] if ; -: ?hash* ( key hash/f -- value/f ) +: ?hash* ( key hash/f -- value/f ? ) dup [ hash* ] [ 2drop f f ] if ; IN: hashtables-internals diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index ad366088aa..50bf378756 100644 --- a/library/collections/sequence-combinators.factor +++ b/library/collections/sequence-combinators.factor @@ -4,7 +4,7 @@ IN: sequences-internals USING: arrays generic kernel kernel-internals math sequences vectors ; -: collect ( n generator -- array | quot: n -- value ) +: collect ( n quot -- array ) | quot ( n -- value ) >r [ f ] keep r> swap [ [ rot >r [ swap call ] keep r> set-array-nth ] 3keep ] repeat drop ; inline @@ -32,36 +32,36 @@ vectors ; IN: sequences -: each ( seq quot -- | quot: elt -- ) +: each ( seq quot -- ) | quot ( elt -- ) swap dup length [ [ swap nth-unsafe swap call ] 3keep ] repeat 2drop ; inline -: each-with ( obj seq quot -- | quot: obj elt -- ) +: each-with ( obj seq quot -- ) | quot ( obj elt -- ) swap [ with ] each 2drop ; inline -: reduce ( seq identity quot -- value | quot: x y -- z ) +: reduce ( seq identity quot -- value ) | quot ( x y -- z ) swapd each ; inline -: map ( seq quot -- seq | quot: elt -- elt ) +: map ( seq quot -- seq ) | quot ( elt -- elt ) over >r over length [ (map) ] collect r> like 2nip ; inline -: map-with ( obj list quot -- list | quot: obj elt -- elt ) +: map-with ( obj list quot -- list ) | quot ( obj elt -- elt ) swap [ with rot ] map 2nip ; inline -: accumulate ( seq identity quot -- values | quot: x y -- z ) +: accumulate ( seq identity quot -- values ) | quot ( x y -- z ) rot [ pick >r swap call r> ] map-with nip ; inline : change-nth ( i seq quot -- ) -rot [ nth swap call ] 2keep set-nth ; inline -: inject ( seq quot -- | quot: elt -- elt ) +: inject ( seq quot -- ) | quot ( elt -- elt ) over length [ [ -rot change-nth ] 3keep ] repeat 2drop ; inline -: inject-with ( obj seq quot -- | quot: obj elt -- elt ) +: inject-with ( obj seq quot -- ) | quot ( obj elt -- elt ) swap [ with rot ] inject 2drop ; inline : min-length ( seq seq -- n ) @@ -73,7 +73,7 @@ IN: sequences : 2each ( seq seq quot -- ) -rot 2dup min-length [ (2each) ] repeat 3drop ; inline -: 2reduce ( seq seq identity quot -- value | quot: e x y -- z ) +: 2reduce ( seq seq identity quot -- value ) | quot ( e x y -- z ) >r -rot r> 2each ; inline : 2map ( seq seq quot -- seq ) @@ -93,13 +93,13 @@ IN: sequences ] if ] if-bounds ; inline -: find-with* ( obj i seq quot -- i elt | quot: elt -- ? ) +: find-with* ( obj i seq quot -- i elt ) | quot ( elt -- ? ) -rot [ with rot ] find* 2swap 2drop ; inline -: find ( seq quot -- i elt | quot: elt -- ? ) +: find ( seq quot -- i elt ) | quot ( elt -- ? ) 0 -rot find* ; inline -: find-with ( obj seq quot -- i elt | quot: elt -- ? ) +: find-with ( obj seq quot -- i elt ) | quot ( elt -- ? ) swap [ with rot ] find 2swap 2drop ; inline : find-last* ( i seq quot -- i elt ) @@ -111,13 +111,13 @@ IN: sequences ] if ] if-bounds ; inline -: find-last-with* ( obj i seq quot -- i elt | quot: elt -- ? ) +: find-last-with* ( obj i seq quot -- i elt ) | quot ( elt -- ? ) -rot [ with rot ] find-last* 2swap 2drop ; inline : find-last ( seq quot -- i elt ) >r [ length 1- ] keep r> find-last* ; inline -: find-last-with ( obj seq quot -- i elt | quot: elt -- ? ) +: find-last-with ( obj seq quot -- i elt ) | quot ( elt -- ? ) swap [ with rot ] find-last 2swap 2drop ; inline : contains? ( seq quot -- ? ) @@ -129,20 +129,20 @@ IN: sequences : all? ( seq quot -- ? ) swap [ swap call not ] contains-with? not ; inline -: all-with? ( obj seq quot -- ? | quot: elt -- ? ) +: all-with? ( obj seq quot -- ? ) | quot ( elt -- ? ) swap [ with rot ] all? 2nip ; inline -: subset ( seq quot -- seq | quot: elt -- ? ) +: subset ( seq quot -- seq ) | quot ( elt -- ? ) over >r over length rot [ -rot [ >r over >r call [ r> r> push ] [ r> r> 2drop ] if ] 2keep ] each r> like nip ; inline -: subset-with ( obj seq quot -- seq | quot: obj elt -- ? ) +: subset-with ( obj seq quot -- seq ) | quot ( obj elt -- ? ) swap [ with rot ] subset 2nip ; inline -: monotonic? ( seq quot -- ? | quot: elt elt -- ? ) +: monotonic? ( seq quot -- ? ) | quot ( elt elt -- ? ) swap dup length 1- [ pick pick >r >r (monotonic) r> r> rot ] all? 2nip ; inline @@ -154,7 +154,7 @@ IN: sequences if ] 2each 2drop ; inline -: cache-nth ( i seq quot -- elt | quot: i -- elt ) +: cache-nth ( i seq quot -- elt ) | quot ( i -- elt ) pick pick ?nth dup [ >r 3drop r> ] [ diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index 3ba4984acf..d872cc93b7 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -47,7 +47,7 @@ M: object like drop ; pick pick number= [ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline -: (delete) ( elt store scan seq -- ) +: (delete) ( elt store scan seq -- elt store scan seq ) 2dup length < [ 3dup move [ nth pick = ] 2keep rot diff --git a/library/compiler/alien/compiler.factor b/library/compiler/alien/compiler.factor index eed7e88313..5d001e831f 100644 --- a/library/compiler/alien/compiler.factor +++ b/library/compiler/alien/compiler.factor @@ -22,7 +22,7 @@ kernel-internals math namespaces sequences words ; : fastcall-param ( reg-class -- n reg-class ) [ dup class get swap inc-reg-class ] keep ; -: alloc-parameter ( parameter -- n reg reg-class ) +: alloc-parameter ( parameter -- reg reg-class ) #! Allocate a register and stack frame location. #! n is a stack location, and the value of the class #! variable is a register number. diff --git a/library/compiler/alien/structs.factor b/library/compiler/alien/structs.factor index ddc21800d2..b50e090465 100644 --- a/library/compiler/alien/structs.factor +++ b/library/compiler/alien/structs.factor @@ -31,7 +31,6 @@ sequences strings words ; : define-field ( offset type name -- offset ) >r dup >r c-align align r> r> "struct-name" get swap "-" swap append3 - ( offset type name -- ) 3dup define-getter 3dup define-setter drop c-size + ; diff --git a/library/compiler/generator/architecture.factor b/library/compiler/generator/architecture.factor index 6f183c02c5..af3cb2582f 100644 --- a/library/compiler/generator/architecture.factor +++ b/library/compiler/generator/architecture.factor @@ -133,7 +133,7 @@ M: float-regs inc-reg-class dup (inc-reg-class) macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ; -GENERIC: v>operand +GENERIC: v>operand ( obj -- operand ) M: integer v>operand tag-bits shift ; M: vreg v>operand dup vreg-n swap vregs nth ; M: f v>operand drop object-tag ; diff --git a/library/compiler/generator/generator.factor b/library/compiler/generator/generator.factor index d40c27f43e..74fdad764a 100644 --- a/library/compiler/generator/generator.factor +++ b/library/compiler/generator/generator.factor @@ -4,7 +4,7 @@ IN: compiler USING: arrays assembler errors generic hashtables inference kernel kernel-internals math namespaces sequences words ; -GENERIC: stack-reserve* +GENERIC: stack-reserve* ( node -- n ) M: object stack-reserve* drop 0 ; @@ -44,7 +44,7 @@ UNION: #terminal V{ } clone literal-table set V{ } clone label-table set ; -: generate-1 ( word node quot -- | quot: node -- ) +: generate-1 ( word node quot -- ) | quot ( node -- ) #! Generate the code, then dump three vectors to pass to #! add-compiled-block. pick f save-xt [ @@ -99,10 +99,10 @@ M: #if generate-node : [with-template] ( quot template -- quot ) 2array >quotation [ with-template ] append ; -: define-intrinsic ( word quot template -- | quot: -- ) +: define-intrinsic ( word quot template -- ) | quot ( -- ) [with-template] "intrinsic" set-word-prop ; -: define-if-intrinsic ( word quot template -- | quot: label -- ) +: define-if-intrinsic ( word quot template -- ) | quot ( label -- ) [with-template] "if-intrinsic" set-word-prop ; : if>boolean-intrinsic ( label -- ) diff --git a/library/compiler/generator/templates.factor b/library/compiler/generator/templates.factor index cd50b47625..38ce86fe8f 100644 --- a/library/compiler/generator/templates.factor +++ b/library/compiler/generator/templates.factor @@ -37,7 +37,7 @@ C: phantom-stack ( -- stack ) 0 over set-phantom-stack-height V{ } clone over set-delegate ; -GENERIC: finalize-height ( n stack -- ) +GENERIC: finalize-height ( stack -- ) GENERIC: ( n stack -- loc ) @@ -240,7 +240,7 @@ SYMBOL: +clobber : requested-vregs ( template -- int# float# ) dup length swap [ float eq? ] subset length [ - ] keep ; -: (requests-class?) ( class template -- ) +: (requests-class?) ( class template -- ? ) [ second reg-spec>class eq? ] contains-with? ; : requests-class? ( class -- ? ) diff --git a/library/compiler/generator/xt.factor b/library/compiler/generator/xt.factor index 75671d2e76..a920bf2e41 100644 --- a/library/compiler/generator/xt.factor +++ b/library/compiler/generator/xt.factor @@ -43,7 +43,7 @@ SYMBOL: label-table : rel-relative-2 5 ; : rel-relative-3 6 ; -: (rel) ( arg class type offset -- { type offset } ) +: (rel) ( arg class type offset -- pair ) #! Write a relocation instruction for the runtime image #! loader. pick rel-absolute-cell = cell 4 ? - diff --git a/library/compiler/inference/branches.factor b/library/compiler/inference/branches.factor index 47d654e42b..528257c234 100644 --- a/library/compiler/inference/branches.factor +++ b/library/compiler/inference/branches.factor @@ -7,7 +7,7 @@ namespaces parser prettyprint sequences strings vectors words ; : unify-lengths ( seq -- seq ) #! Pad all vectors to the same length. If one vector is #! shorter, pad it with unknown results at the bottom. - dup 0 [ length max ] reduce + dup [ length ] map supremum swap [ add-inputs nip ] map-with ; : unify-values ( seq -- value ) @@ -25,7 +25,7 @@ namespaces parser prettyprint sequences strings vectors words ; [ swap unparse " " rot length unparse append3 ] 2map "Unbalanced branches:" add* "\n" join inference-error ; -: unify-inputs ( max-d-in meta-d -- meta-d ) +: unify-inputs ( max-d-in d-in meta-d -- meta-d ) dup [ [ >r - r> length + ] keep add-inputs nip ] [ @@ -72,42 +72,16 @@ namespaces parser prettyprint sequences strings vectors words ; dataflow-graph off current-node off ; -: no-base-case ( -- ) - "Cannot infer base case" inference-error ; - -: recursive-branch ( hash ? -- obj ) - #! If the branch made an unresolved recursive call, and we - #! are inferring the base case, ignore the branch (the base - #! case being the stack effect of the branches not making - #! recursive calls). Otherwise, raise an error. - [ - base-case-continuation get - [ drop f ] [ no-base-case ] if - ] when ; - : infer-branch ( value -- namespace ) - #! Return a namespace with inferencer variables: - #! meta-d, meta-r, d-in. They are set to f if - #! terminate was called. [ - [ - base-case-continuation set - copy-inference - dup value-recursion recursive-state set - dup value-literal infer-quot - terminated? get [ #values node, ] unless - f - ] callcc1 nip - ] make-hash swap recursive-branch ; - -: notify-base-case ( -- ) - base-case-continuation get - [ t swap continue-with ] [ no-base-case ] if* ; + copy-inference + dup value-recursion recursive-state set + value-literal infer-quot + terminated? get [ #values node, ] unless + ] make-hash ; : (infer-branches) ( branchlist -- list ) - [ infer-branch ] map [ ] subset - dup empty? [ notify-base-case ] when - dup unify-effects unify-dataflow ; + [ infer-branch ] map dup unify-effects unify-dataflow ; : infer-branches ( branches node -- ) #! Recursive stack effect inference is done here. If one of diff --git a/library/compiler/inference/dataflow.factor b/library/compiler/inference/dataflow.factor index c8337358d2..322161a7e1 100644 --- a/library/compiler/inference/dataflow.factor +++ b/library/compiler/inference/dataflow.factor @@ -144,7 +144,7 @@ SYMBOL: current-node : #drop ( n -- #shuffle ) d-tail in-node <#shuffle> ; -: each-node ( node quot -- | quot: node -- ) +: each-node ( node quot -- ) | quot ( node -- ) over [ [ call ] 2keep swap [ node-children [ swap each-node ] each-with ] 2keep @@ -153,10 +153,10 @@ SYMBOL: current-node 2drop ] if ; inline -: each-node-with ( obj node quot -- | quot: obj node -- ) +: each-node-with ( obj node quot -- ) | quot ( obj node -- ) swap [ with ] each-node 2drop ; inline -: all-nodes? ( node quot -- ? | quot: node -- ? ) +: all-nodes? ( node quot -- ? ) | quot ( node -- ? ) over [ [ call ] 2keep rot [ [ @@ -173,7 +173,7 @@ SYMBOL: current-node 2drop t ] if ; inline -: all-nodes-with? ( obj node quot -- ? | quot: obj node -- ? ) +: all-nodes-with? ( obj node quot -- ? ) | quot ( obj node -- ? ) swap [ with rot ] all-nodes? 2nip ; inline : remember-node ( word node -- ) @@ -237,20 +237,20 @@ DEFER: (map-nodes) drop ] if* ; inline -: (map-nodes) ( prev quot -- | quot: node -- node ) +: (map-nodes) ( prev quot -- ) | quot ( node -- node ) node@ [ [ map-node ] keep map-next ] [ drop f swap ?set-node-successor ] if ; inline -: map-first ( node quot -- node | quot: node -- node ) +: map-first ( node quot -- node ) | quot ( node -- node ) call node> drop dup >node ; inline -: map-nodes ( node quot -- node | quot: node -- node ) +: map-nodes ( node quot -- node ) | quot ( node -- node ) over [ over >node [ map-first ] keep map-next node> ] when drop ; inline -: map-children ( quot -- | quot: node -- node ) +: map-children ( quot -- ) | quot ( node -- node ) node@ [ node-children [ swap map-nodes ] map-with ] keep set-node-children ; inline diff --git a/library/compiler/inference/inference.factor b/library/compiler/inference/inference.factor index bef6b06d84..548fcede4e 100644 --- a/library/compiler/inference/inference.factor +++ b/library/compiler/inference/inference.factor @@ -5,10 +5,6 @@ USING: arrays errors generic inspector interpreter io kernel math namespaces parser prettyprint sequences strings vectors words ; -! Called when a recursive call during base case inference is -! found. Either tries to infer another branch, or gives up. -SYMBOL: base-case-continuation - TUPLE: inference-error message rstate data-stack call-stack ; : inference-error ( msg -- * ) @@ -81,7 +77,7 @@ M: wrapper apply-object wrapped apply-literal ; #! Ignore this branch's stack effect. terminated? on #terminate node, ; -GENERIC: infer-quot +GENERIC: infer-quot ( quot -- ) M: f infer-quot drop ; @@ -105,14 +101,13 @@ M: quotation infer-quot : with-infer ( quot -- ) [ [ - base-case-continuation off { } recursive-state set V{ } clone recorded set f init-inference call check-return ] [ - recorded get dup . [ f "infer-effect" set-word-prop ] each + recorded get [ f "infer-effect" set-word-prop ] each rethrow ] recover ] with-scope ; diff --git a/library/compiler/inference/words.factor b/library/compiler/inference/words.factor index 539d7b9126..cf44d624a9 100644 --- a/library/compiler/inference/words.factor +++ b/library/compiler/inference/words.factor @@ -14,12 +14,23 @@ IN: inference >r [ drop ] map dup r> set-node-out-d meta-d get swap nappend ; +: recursing? ( word -- label/f ) + recursive-state get assoc ; + +: make-call-node ( word -- node ) + dup "inline" word-prop + [ dup recursing? [ #call-label ] [ #call ] ?if ] + [ #call ] + if ; + : consume/produce ( word effect -- ) #! Add a node to the dataflow graph that consumes and #! produces a number of values. - swap #call + meta-d get clone >r + swap make-call-node over effect-in length over consume-values over effect-out length over produce-values + r> over #call-label? [ over set-node-in-d ] [ drop ] if node, effect-terminated? [ terminate ] when ; : no-effect ( word -- ) @@ -27,21 +38,19 @@ IN: inference " was already attempted, and failed" append3 inference-error ; -TUPLE: rstate label count ; - : nest-node ( -- ) #entry node, ; : unnest-node ( new-node -- new-node ) dup node-param #return node, dataflow-graph get 1array over set-node-children ; -: add-recursive-state ( word label count -- ) - 2array recursive-state [ swap add ] change ; +: add-recursive-state ( word label -- ) + 2array recursive-state [ swap add ] change ; -: inline-block ( word count -- node-block variables ) +: inline-block ( word -- node-block variables ) [ copy-inference nest-node - >r gensym 2dup r> add-recursive-state + gensym 2dup add-recursive-state #label >r word-def infer-quot r> unnest-node ] make-hash ; @@ -69,7 +78,7 @@ M: #call-label collect-recursion* #! and which don't (loop indices, etc). The latter cannot #! be folded. collect-recursion meta-d get add unify-lengths unify-stacks - meta-d [ length tail* ] change ; + meta-d [ length tail* >vector ] change ; : splice-node ( node -- ) #! Labels which do not call themselves are just spliced into @@ -84,23 +93,18 @@ M: #call-label collect-recursion* #! closure under recursive value substitution. #! If the block does not call itself, there is no point in #! having the block node in the IR. Just add its contents. - dup 0 inline-block over recursive-label? [ + dup inline-block over recursive-label? [ meta-d get >r - drop join-values 0 inline-block apply-infer + drop join-values inline-block apply-infer r> over set-node-in-d node, ] [ apply-infer node-child node-successor splice-node drop ] if ; -: infer-compound ( word count -- effect ) - #! Infer a word's stack effect in a separate inferencer - #! instance. Outputs a true boolean if the word terminates - #! control flow by throwing an exception or restoring a - #! continuation. +: infer-compound ( word -- effect ) [ recursive-state get init-inference - over >r inline-block nip - [ current-effect ] bind r> + [ inline-block nip [ current-effect ] bind ] keep ] with-scope over consume/produce ; GENERIC: apply-word @@ -111,7 +115,7 @@ M: object apply-word TUPLE: effect-error word effect ; -: effect-error ( -- * ) throw ; +: effect-error ( word effect -- * ) throw ; : check-effect ( word effect -- ) over recorded get push @@ -122,7 +126,7 @@ TUPLE: effect-error word effect ; M: compound apply-word #! Infer a compound word's stack effect. [ - dup 0 infer-compound check-effect + dup infer-compound check-effect ] [ swap t "no-effect" set-word-prop rethrow ] recover ; @@ -158,7 +162,7 @@ M: symbol apply-object apply-literal ; M: compound apply-object #! Apply the word's stack effect to the inferencer state. - dup recursive-state get assoc [ + dup recursing? [ dup recursive-effect consume/produce ] [ dup "inline" word-prop diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor index 54131a5415..312ff0cb87 100644 --- a/library/compiler/optimizer/call-optimizers.factor +++ b/library/compiler/optimizer/call-optimizers.factor @@ -30,7 +30,7 @@ math math-internals sequences words parser ; [ with-datastack ] catch [ 3drop t ] [ inline-literals ] if ; -: call>no-op ( not -- ) +: call>no-op ( not -- node/f ) #! Note: cloning the vectors, since subst-values will modify #! them. [ node-in-d clone ] keep diff --git a/library/compiler/optimizer/print-dataflow.factor b/library/compiler/optimizer/print-dataflow.factor index 741211f045..556f4ef859 100644 --- a/library/compiler/optimizer/print-dataflow.factor +++ b/library/compiler/optimizer/print-dataflow.factor @@ -5,7 +5,7 @@ math namespaces prettyprint sequences styles vectors words ; ! A simple tool for turning dataflow IR into quotations, for ! debugging purposes. -GENERIC: node>quot ( node -- ) +GENERIC: node>quot ( ? node -- ) TUPLE: comment node text ; diff --git a/library/compiler/ppc/architecture.factor b/library/compiler/ppc/architecture.factor index 75eb99cc80..8b4024813d 100644 --- a/library/compiler/ppc/architecture.factor +++ b/library/compiler/ppc/architecture.factor @@ -25,7 +25,7 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; : stack@ macosx? 24 8 ? + ; : lr@ macosx? 8 4 ? + ; -GENERIC: loc>operand +GENERIC: loc>operand ( loc -- reg n ) M: ds-loc loc>operand ds-loc-n cells neg 14 swap ; M: cs-loc loc>operand cs-loc-n cells neg 15 swap ; diff --git a/library/compiler/ppc/assembler.factor b/library/compiler/ppc/assembler.factor index 8cadd5bd65..f7a44c7920 100644 --- a/library/compiler/ppc/assembler.factor +++ b/library/compiler/ppc/assembler.factor @@ -166,7 +166,7 @@ M: label (B) 0 -rot (B) rel-relative-3 rel-label ; : B 0 0 (B) ; : BL 0 1 (B) ; -GENERIC: BC +GENERIC: BC ( a b c -- ) M: integer BC 0 0 b-form 16 insn ; M: word BC >r 0 BC r> rel-relative-2 rel-word ; M: label BC >r 0 BC r> rel-relative-2 rel-label ; diff --git a/library/errors.factor b/library/errors.factor index cebab838ac..e3beb69f6d 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -42,7 +42,7 @@ C: condition ( error restarts cc -- condition ) : condition ( error restarts -- restart ) [ throw ] callcc1 2nip ; -GENERIC: compute-restarts +GENERIC: compute-restarts ( error -- seq ) M: object compute-restarts drop { } ; diff --git a/library/generic/classes.factor b/library/generic/classes.factor index a04af708ef..72414706f7 100644 --- a/library/generic/classes.factor +++ b/library/generic/classes.factor @@ -3,7 +3,7 @@ IN: generic USING: arrays definitions errors hashtables kernel kernel-internals namespaces parser sequences strings words -vectors math ; +vectors math parser ; PREDICATE: word class "class" word-prop ; @@ -17,8 +17,11 @@ SYMBOL: builtins : predicate-word ( word -- word ) word-name "?" append create-in ; +: predicate-effect 1 1 ; + : define-predicate ( class predicate quot -- ) over [ + over predicate-effect "declared-effect" set-word-prop dupd define-compound 2dup unit "predicate" set-word-prop swap "predicating" set-word-prop diff --git a/library/help/porter-stemmer.factor b/library/help/porter-stemmer.factor index ab3a843c0f..6482f43c27 100644 --- a/library/help/porter-stemmer.factor +++ b/library/help/porter-stemmer.factor @@ -138,7 +138,7 @@ USING: kernel math parser sequences ; } } cond ; -: step1b ( str -- str ? ) +: step1b ( str -- str ) { { [ "eed" ?tail ] [ -eed ] } { diff --git a/library/help/topics.factor b/library/help/topics.factor index 551bb25f7c..0de1318385 100644 --- a/library/help/topics.factor +++ b/library/help/topics.factor @@ -5,7 +5,7 @@ USING: arrays definitions errors generic graphs hashtables inspector io kernel namespaces prettyprint sequences words ; ! Markup -GENERIC: print-element +GENERIC: print-element ( element -- ) ! Help articles SYMBOL: articles diff --git a/library/io/unix/io.factor b/library/io/unix/io.factor index a9920b885a..5ea2a33244 100644 --- a/library/io/unix/io.factor +++ b/library/io/unix/io.factor @@ -91,7 +91,7 @@ M: port set-timeout ! Associates a port with a list of continuations waiting on the ! port to finish I/O TUPLE: io-task port callbacks ; -C: io-task ( port -- ) +C: io-task ( port -- task ) [ set-io-task-port ] keep V{ } clone over set-io-task-callbacks ; @@ -132,7 +132,7 @@ GENERIC: task-container ( task -- vector ) ] if ] hash-each-with ; -: init-fdset ( fdset tasks -- ) +: init-fdset ( fdset tasks -- fdset ) >r dup dup FD_SETSIZE clear-bits r> [ drop t swap rot set-bit-nth ] hash-each-with ; @@ -204,7 +204,7 @@ M: input-port stream-read1 ! Reading character counts : read-step ( count reader -- ? ) - dup port-sbuf -rot >r over length - ( remaining) r> + dup port-sbuf -rot >r over length - r> 2dup buffer-length <= [ buffer> nappend t ] [ diff --git a/library/io/unix/sockets.factor b/library/io/unix/sockets.factor index 6dfb557c2a..161d3e0d89 100644 --- a/library/io/unix/sockets.factor +++ b/library/io/unix/sockets.factor @@ -32,14 +32,14 @@ threads unix-internals ; : server-sockaddr ( port -- sockaddr ) init-sockaddr INADDR_ANY htonl over set-sockaddr-in-addr ; -: sockopt ( fd level opt value -- ) +: sockopt ( fd level opt -- ) 1 "int" c-size setsockopt io-error ; : server-socket ( port -- fd ) server-sockaddr [ dup SOL_SOCKET SO_REUSEADDR sockopt swap dupd "sockaddr-in" c-size bind - dup 0 >= [ drop 1 listen ] [ ( fd n - n) nip ] if + dup 0 >= [ drop 1 listen ] [ nip ] if ] with-socket-fd ; TUPLE: connect-task ; diff --git a/library/math/math.factor b/library/math/math.factor index 6330994c6d..0e1ec31c89 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -64,7 +64,7 @@ M: object zero? drop f ; : repeat 0 -rot (repeat) ; inline -: times ( n quot -- | quot: -- ) +: times ( n quot -- ) | quot ( -- ) swap [ >r dup slip r> ] repeat drop ; inline GENERIC: number>string ( n -- str ) foldable diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index 5b244aa761..c3a49677b7 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -92,7 +92,7 @@ TUPLE: bad-escape ; SYMBOL: effect-stack -: (parse-effect) +: (parse-effect) ( -- ) scan [ dup ")" = [ drop ] [ , (parse-effect) ] if ] [ diff --git a/library/test/inference.factor b/library/test/inference.factor index e5f716cf74..1eae0fa0f5 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -205,7 +205,7 @@ DEFER: blah4 [ swap slip ] keep swap bad-combinator ] if ; inline -! [ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails +[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails ! Regression : bad-input# diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 40949d66f4..43be642d6e 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -90,6 +90,6 @@ SYMBOL: restarts : init-error-handler ( -- ) V{ } clone set-catchstack - ( kernel calls on error ) + ! kernel calls on error [ error-handler ] 5 setenv \ kernel-error 12 setenv ; diff --git a/library/ui/freetype/freetype-gl.factor b/library/ui/freetype/freetype-gl.factor index 52cf0f3ede..30f385ad3a 100644 --- a/library/ui/freetype/freetype-gl.factor +++ b/library/ui/freetype/freetype-gl.factor @@ -87,12 +87,12 @@ C: font ( handle -- font ) [ set-font-handle ] keep dup init-font V{ } clone over set-font-widths ; -: open-font ( { font style ptsize } -- font ) +: open-font ( fontspec -- font ) #! Open a font and set the point size of the font. first3 >r open-face dup 0 r> 6 shift dpi dpi FT_Set_Char_Size freetype-error ; -: lookup-font ( { font style ptsize } -- font ) +: lookup-font ( fontspec -- font ) #! Cache open fonts. open-fonts get [ open-font ] cache ; diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 4d864b71ac..2297c01c93 100644 --- a/library/ui/gadgets.factor +++ b/library/ui/gadgets.factor @@ -76,8 +76,7 @@ M: gadget children-on nip gadget-children ; : pick-up-list ( rect/point gadget -- gadget/f ) dupd children-on [ inside? ] find-with nip ; -: translate ( rect/point -- new-origin ) - rect-loc origin [ v+ ] change ; +: translate ( rect/point -- ) rect-loc origin [ v+ ] change ; : pick-up ( rect/point gadget -- gadget ) [ diff --git a/library/ui/gadgets/labels.factor b/library/ui/gadgets/labels.factor index ea029c0221..530e9b07fe 100644 --- a/library/ui/gadgets/labels.factor +++ b/library/ui/gadgets/labels.factor @@ -13,7 +13,7 @@ C: label ( text -- label ) [ set-label-text ] keep dup label-theme ; -: label-size ( gadget text -- dim ) +: label-size ( gadget -- dim ) dup label-font lookup-font dup font-height >r swap label-text string-width r> 2array ; diff --git a/library/ui/gadgets/scrolling.factor b/library/ui/gadgets/scrolling.factor index 196a2ee5f7..57057d34cc 100644 --- a/library/ui/gadgets/scrolling.factor +++ b/library/ui/gadgets/scrolling.factor @@ -9,7 +9,7 @@ gadgets-viewports generic kernel math namespaces sequences ; ! down on the next relayout. TUPLE: scroller viewport x y follows ; -: scroller-origin ( scroller -- { x y } ) +: scroller-origin ( scroller -- point ) dup scroller-x slider-value swap scroller-y slider-value 2array ; diff --git a/library/ui/hierarchy.factor b/library/ui/hierarchy.factor index 2cf31ebcdd..e6d49b2084 100644 --- a/library/ui/hierarchy.factor +++ b/library/ui/hierarchy.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: gadgets USING: generic hashtables inference kernel math namespaces -sequences vectors words ; +sequences vectors words parser ; GENERIC: graft* ( gadget -- ) @@ -61,7 +61,7 @@ M: gadget ungraft* drop ; #! Add all gadgets in a sequence to a parent gadget. swap [ over (add-gadget) ] each relayout ; -: add-spec ( quot { quot setter post loc } -- ) +: add-spec ( quot spec -- ) dup first % dup second [ [ dup gadget get ] % , ] when* dup third % @@ -75,7 +75,7 @@ M: gadget ungraft* drop ; : build-spec ( spec quot -- ) swap (build-spec) call ; -\ build-spec { 2 0 } "infer-effect" set-word-prop +\ build-spec 2 0 "infer-effect" set-word-prop \ build-spec [ pop-literal pop-literal nip (build-spec) infer-quot-value diff --git a/library/ui/opengl/opengl-utils.factor b/library/ui/opengl/opengl-utils.factor index 144768dbf3..96ac27e87a 100644 --- a/library/ui/opengl/opengl-utils.factor +++ b/library/ui/opengl/opengl-utils.factor @@ -81,7 +81,7 @@ sequences ; ! A sprite is a texture and a display list. TUPLE: sprite dlist texture loc dim dim2 ; -C: sprite ( loc dim dim2 -- ) +C: sprite ( loc dim dim2 -- sprite ) [ set-sprite-dim2 ] keep [ set-sprite-dim ] keep [ set-sprite-loc ] keep ; @@ -116,7 +116,7 @@ C: sprite ( loc dim dim2 -- ) GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameterf GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameterf ; -: gl-translate ( { x y } -- ) first2 0.0 glTranslated ; +: gl-translate ( point -- ) first2 0.0 glTranslated ; : draw-sprite ( sprite -- ) dup sprite-loc gl-translate diff --git a/library/ui/text/document.factor b/library/ui/text/document.factor index 9ec1e2b379..233367937e 100644 --- a/library/ui/text/document.factor +++ b/library/ui/text/document.factor @@ -53,7 +53,7 @@ C: document ( -- document ) tuck >r >r document get -rot start-on-line r> r> document get -rot end-on-line ; -: (doc-range) ( startloc endloc line# -- str ) +: (doc-range) ( startloc endloc line# -- ) [ start/end-on-line ] keep document get doc-line , ; : doc-range ( startloc endloc document -- str ) @@ -70,10 +70,10 @@ C: document ( -- document ) first swap length 1- + 0 ] if r> peek length + 2array ; -: prepend-first ( str seq -- seq ) +: prepend-first ( str seq -- ) 0 swap [ append ] change-nth ; -: append-last ( str seq -- seq ) +: append-last ( str seq -- ) [ length 1- ] keep [ swap append ] change-nth ; : loc-col/str ( loc document -- str col ) diff --git a/library/ui/text/editor.factor b/library/ui/text/editor.factor index 2bc8dad788..904da055fc 100644 --- a/library/ui/text/editor.factor +++ b/library/ui/text/editor.factor @@ -20,7 +20,7 @@ TUPLE: loc-monitor editor ; dup over set-editor-caret dup swap set-editor-mark ; -C: editor ( document -- editor ) +C: editor ( -- editor ) dup delegate>control dup dup set-control-self dup init-editor-locs diff --git a/library/ui/world.factor b/library/ui/world.factor index b5b3059e83..b6baa5784b 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -65,7 +65,7 @@ M: world model-changed : focused-ancestors ( world -- seq ) world-focus parents ; -: font-sprites ( font world -- { open-font sprites } ) +: font-sprites ( font world -- pair ) world-fonts [ lookup-font V{ } clone 2array ] cache ; : draw-string ( font string -- ) diff --git a/library/words.factor b/library/words.factor index 4520fae669..d8bd424ca9 100644 --- a/library/words.factor +++ b/library/words.factor @@ -49,10 +49,10 @@ M: symbol definer drop \ SYMBOL: ; [ rot word-props set-hash ] [ nip remove-word-prop ] if ; -GENERIC: word-xt +GENERIC: word-xt ( word -- xt ) M: word word-xt 7 integer-slot ; -GENERIC: set-word-xt +GENERIC: set-word-xt ( xt word -- ) M: word set-word-xt 7 set-integer-slot ; SYMBOL: vocabularies diff --git a/vm/compiler.c b/vm/compiler.c index 0ee40d5856..5da0802562 100644 --- a/vm/compiler.c +++ b/vm/compiler.c @@ -53,7 +53,7 @@ CELL get_rel_word(F_REL *rel, CELL literal_start) CELL arg = REL_ARGUMENT(rel); F_WORD *word = untag_word(get_literal(literal_start,arg)); if(word->xt < compiling.base || word->xt >= compiling.limit) - critical_error("Bad XT",tag_word(word)); + fprintf(stderr,"Bad XT %x",tag_word(word)); return word->xt; }