diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 62130cb179..632938bb2d 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -85,8 +85,16 @@ SYMBOL: objects : 1-offset 8 ; inline : -1-offset 9 ; inline +SYMBOL: sub-primitives + +: make-jit ( quot rc rt offset -- quad ) + { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline + : jit-define ( quot rc rt offset name -- ) - >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ; + >r make-jit r> set ; inline + +: define-sub-primitive ( quot rc rt offset word -- ) + >r make-jit r> sub-primitives get set-at ; ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -118,29 +126,7 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling -SYMBOL: jit-tag -SYMBOL: jit-tag-word -SYMBOL: jit-eq? -SYMBOL: jit-eq?-word -SYMBOL: jit-slot -SYMBOL: jit-slot-word SYMBOL: jit-declare-word -SYMBOL: jit-drop -SYMBOL: jit-drop-word -SYMBOL: jit-dup -SYMBOL: jit-dup-word -SYMBOL: jit->r -SYMBOL: jit->r-word -SYMBOL: jit-r> -SYMBOL: jit-r>-word -SYMBOL: jit-swap -SYMBOL: jit-swap-word -SYMBOL: jit-over -SYMBOL: jit-over-word -SYMBOL: jit-fixnum-fast -SYMBOL: jit-fixnum-fast-word -SYMBOL: jit-fixnum>= -SYMBOL: jit-fixnum>=-word ! Default definition for undefined words SYMBOL: undefined-quot @@ -163,29 +149,7 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } - { jit-tag 36 } - { jit-tag-word 37 } - { jit-eq? 38 } - { jit-eq?-word 39 } - { jit-slot 40 } - { jit-slot-word 41 } { jit-declare-word 42 } - { jit-drop 43 } - { jit-drop-word 44 } - { jit-dup 45 } - { jit-dup-word 46 } - { jit->r 47 } - { jit->r-word 48 } - { jit-r> 49 } - { jit-r>-word 50 } - { jit-swap 51 } - { jit-swap-word 52 } - { jit-over 53 } - { jit-over-word 54 } - { jit-fixnum-fast 55 } - { jit-fixnum-fast-word 56 } - { jit-fixnum>= 57 } - { jit-fixnum>=-word 58 } { undefined-quot 60 } } at header-size + ; @@ -305,6 +269,9 @@ M: f ' ! Words +: word-sub-primitive ( word -- obj ) + global [ target-word ] bind sub-primitives get at ; + : emit-word ( word -- ) [ [ subwords [ emit-word ] each ] @@ -316,12 +283,13 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] + [ drop f , ] + [ drop 0 , ] ! count + [ word-sub-primitive , ] + [ drop 0 , ] ! xt + [ drop 0 , ] ! code + [ drop 0 , ] ! profiling } cleave - f , - 0 , ! count - 0 , ! xt - 0 , ! code - 0 , ! profiling ] { } make [ ' ] map ] bi \ word type-number object tag-number @@ -460,18 +428,7 @@ M: quotation ' \ if jit-if-word set \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set - \ tag jit-tag-word set - \ eq? jit-eq?-word set - \ slot jit-slot-word set \ declare jit-declare-word set - \ drop jit-drop-word set - \ dup jit-dup-word set - \ >r jit->r-word set - \ r> jit-r>-word set - \ swap jit-swap-word set - \ over jit-over-word set - \ fixnum-fast jit-fixnum-fast-word set - \ fixnum>= jit-fixnum>=-word set [ undefined ] undefined-quot set { jit-code-format @@ -488,29 +445,7 @@ M: quotation ' jit-epilog jit-return jit-profiling - jit-tag - jit-tag-word - jit-eq? - jit-eq?-word - jit-slot - jit-slot-word jit-declare-word - jit-drop - jit-drop-word - jit-dup - jit-dup-word - jit->r - jit->r-word - jit-r> - jit-r>-word - jit-swap - jit-swap-word - jit-over - jit-over-word - jit-fixnum-fast - jit-fixnum-fast-word - jit-fixnum>= - jit-fixnum>=-word undefined-quot } [ emit-userenv ] each ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6498dfde60..d748e063c2 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -13,6 +13,8 @@ IN: bootstrap.primitives crossref off +H{ } clone sub-primitives set + "resource:core/bootstrap/syntax.factor" parse-file "resource:core/cpu/" architecture get { @@ -256,6 +258,7 @@ bi "props" { "compiled" read-only } { "counter" { "fixnum" "math" } } + { "sub-primitive" read-only } } define-builtin "byte-array" "byte-arrays" create { } define-builtin @@ -323,14 +326,55 @@ tuple [ tuple-layout [ ] curry ] tri (( quot1 quot2 -- compose )) define-declared +! Sub-primitive words +: make-sub-primitive ( word vocab -- ) + create + dup reset-word + dup 1quotation define ; + +{ + { "(execute)" "words.private" } + { "(call)" "kernel.private" } + { "fixnum+fast" "math.private" } + { "fixnum-fast" "math.private" } + { "fixnum*fast" "math.private" } + { "fixnum-bitand" "math.private" } + { "fixnum-bitor" "math.private" } + { "fixnum-bitxor" "math.private" } + { "fixnum-bitnot" "math.private" } + { "fixnum<" "math.private" } + { "fixnum<=" "math.private" } + { "fixnum>" "math.private" } + { "fixnum>=" "math.private" } + { "drop" "kernel" } + { "2drop" "kernel" } + { "3drop" "kernel" } + { "dup" "kernel" } + { "2dup" "kernel" } + { "3dup" "kernel" } + { "rot" "kernel" } + { "-rot" "kernel" } + { "dupd" "kernel" } + { "swapd" "kernel" } + { "nip" "kernel" } + { "2nip" "kernel" } + { "tuck" "kernel" } + { "over" "kernel" } + { "pick" "kernel" } + { "swap" "kernel" } + { ">r" "kernel" } + { "r>" "kernel" } + { "eq?" "kernel" } + { "tag" "kernel.private" } + { "slot" "slots.private" } +} [ make-sub-primitive ] assoc-each + ! Primitive words : make-primitive ( word vocab n -- ) >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; { - { "(execute)" "words.private" } - { "(call)" "kernel.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -346,24 +390,13 @@ tuple { "bits>double" "math" } { "" "math.private" } { "fixnum+" "math.private" } - { "fixnum+fast" "math.private" } { "fixnum-" "math.private" } - { "fixnum-fast" "math.private" } { "fixnum*" "math.private" } - { "fixnum*fast" "math.private" } { "fixnum/i" "math.private" } { "fixnum-mod" "math.private" } { "fixnum/mod" "math.private" } - { "fixnum-bitand" "math.private" } - { "fixnum-bitor" "math.private" } - { "fixnum-bitxor" "math.private" } - { "fixnum-bitnot" "math.private" } { "fixnum-shift" "math.private" } { "fixnum-shift-fast" "math.private" } - { "fixnum<" "math.private" } - { "fixnum<=" "math.private" } - { "fixnum>" "math.private" } - { "fixnum>=" "math.private" } { "bignum=" "math.private" } { "bignum+" "math.private" } { "bignum-" "math.private" } @@ -395,25 +428,6 @@ tuple { "float>=" "math.private" } { "" "words" } { "word-xt" "words" } - { "drop" "kernel" } - { "2drop" "kernel" } - { "3drop" "kernel" } - { "dup" "kernel" } - { "2dup" "kernel" } - { "3dup" "kernel" } - { "rot" "kernel" } - { "-rot" "kernel" } - { "dupd" "kernel" } - { "swapd" "kernel" } - { "nip" "kernel" } - { "2nip" "kernel" } - { "tuck" "kernel" } - { "over" "kernel" } - { "pick" "kernel" } - { "swap" "kernel" } - { ">r" "kernel" } - { "r>" "kernel" } - { "eq?" "kernel" } { "getenv" "kernel.private" } { "setenv" "kernel.private" } { "(exists?)" "io.files.private" } @@ -433,7 +447,6 @@ tuple { "code-room" "memory" } { "os-env" "system" } { "millis" "system" } - { "tag" "kernel.private" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } @@ -468,7 +481,6 @@ tuple { "set-alien-cell" "alien.accessors" } { "(throw)" "kernel.private" } { "alien-address" "alien" } - { "slot" "slots.private" } { "set-slot" "slots.private" } { "string-nth" "strings.private" } { "set-string-nth" "strings.private" } diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 622c63d7f0..80f0b4f515 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -18,8 +18,8 @@ IN: compiler.constants : underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; : class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; -: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ; +: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; : quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; -: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ; +: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; : compiled-header-size ( -- n ) 4 bootstrap-cells ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bf176eebfa..bd90ca65f0 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts compiler.units math generator.fixup -compiler.constants vocabs ; +USING: bootstrap.image.private kernel kernel.private namespaces +system cpu.x86.assembler layouts compiler.units math math.private +generator.fixup compiler.constants vocabs slots.private words +words.private ; IN: bootstrap.x86 big-endian off @@ -74,27 +75,34 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define +[ + stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame +] f f f jit-epilog jit-define + +[ 0 RET ] f f f jit-return jit-define + +! Sub-primitives + +! Quotations and words +[ + arg0 ds-reg [] MOV ! load from stack + ds-reg bootstrap-cell SUB ! pop stack + arg0 quot-xt-offset [+] JMP ! call quotation +] f f f \ (call) define-sub-primitive + +[ + arg0 ds-reg [] MOV ! load from stack + ds-reg bootstrap-cell SUB ! pop stack + arg0 word-xt-offset [+] JMP ! execute word +] f f f \ (execute) define-sub-primitive + +! Objects [ arg1 ds-reg [] MOV ! load from stack arg1 tag-mask get AND ! compute tag arg1 tag-bits get SHL ! tag the tag ds-reg [] arg1 MOV ! push to stack -] f f f jit-tag jit-define - -: jit-compare ( -- ) - arg1 0 MOV ! load t - arg1 dup [] MOV - temp-reg \ f tag-number MOV ! load f - arg0 ds-reg [] MOV ! load first value - ds-reg bootstrap-cell SUB ! adjust stack pointer - ds-reg [] arg0 CMP ! compare with second value - ; - -[ - jit-compare - arg1 temp-reg CMOVNE ! not equal? - ds-reg [] arg1 MOV ! store -] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define +] f f f \ tag define-sub-primitive [ arg0 ds-reg [] MOV ! load slot number @@ -105,63 +113,187 @@ big-endian off arg1 tag-bits get SHL arg0 arg1 arg0 [+] MOV ! load slot value ds-reg [] arg0 MOV ! push to stack -] f f f jit-slot jit-define +] f f f \ slot define-sub-primitive +! Shufflers [ ds-reg bootstrap-cell SUB -] f f f jit-drop jit-define +] f f f \ drop define-sub-primitive + +[ + ds-reg 2 bootstrap-cells SUB +] f f f \ 2drop define-sub-primitive + +[ + ds-reg 3 bootstrap-cells SUB +] f f f \ 3drop define-sub-primitive [ arg0 ds-reg [] MOV ds-reg bootstrap-cell ADD ds-reg [] arg0 MOV -] f f f jit-dup jit-define +] f f f \ dup define-sub-primitive + +[ + arg0 ds-reg [] MOV + arg1 ds-reg bootstrap-cell neg [+] MOV + ds-reg 2 bootstrap-cells ADD + ds-reg [] arg0 MOV + ds-reg bootstrap-cell neg [+] arg1 MOV +] f f f \ 2dup define-sub-primitive + +[ + arg0 ds-reg [] MOV + arg1 ds-reg -1 bootstrap-cells [+] MOV + temp-reg ds-reg -2 bootstrap-cells [+] MOV + ds-reg 3 bootstrap-cells ADD + ds-reg [] arg0 MOV + ds-reg -1 bootstrap-cells [+] arg1 MOV + ds-reg -2 bootstrap-cells [+] temp-reg MOV +] f f f \ 3dup define-sub-primitive [ - rs-reg bootstrap-cell ADD arg0 ds-reg [] MOV ds-reg bootstrap-cell SUB - rs-reg [] arg0 MOV -] f f f jit->r jit-define + ds-reg [] arg0 MOV +] f f f \ nip define-sub-primitive [ - ds-reg bootstrap-cell ADD - arg0 rs-reg [] MOV - rs-reg bootstrap-cell SUB + arg0 ds-reg [] MOV + ds-reg 2 bootstrap-cells SUB ds-reg [] arg0 MOV -] f f f jit-r> jit-define +] f f f \ 2nip define-sub-primitive + +[ + arg0 ds-reg -1 bootstrap-cells [+] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f \ over define-sub-primitive + +[ + arg0 ds-reg -2 bootstrap-cells [+] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f \ pick define-sub-primitive + +[ + arg0 ds-reg [] MOV + arg1 ds-reg -1 bootstrap-cells [+] MOV + ds-reg [] arg1 MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f \ dupd define-sub-primitive + +[ + arg0 ds-reg [] MOV + arg1 ds-reg -1 bootstrap-cells [+] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV + ds-reg -1 bootstrap-cells [+] arg1 MOV + ds-reg -2 bootstrap-cells [+] arg0 MOV +] f f f \ tuck define-sub-primitive [ arg0 ds-reg [] MOV arg1 ds-reg bootstrap-cell neg [+] MOV ds-reg bootstrap-cell neg [+] arg0 MOV ds-reg [] arg1 MOV -] f f f jit-swap jit-define +] f f f \ swap define-sub-primitive [ - arg0 ds-reg bootstrap-cell neg [+] MOV - ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV -] f f f jit-over jit-define + arg0 ds-reg -1 bootstrap-cells [+] MOV + arg1 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] arg0 MOV + ds-reg -1 bootstrap-cells [+] arg1 MOV +] f f f \ swapd define-sub-primitive [ arg0 ds-reg [] MOV - ds-reg bootstrap-cell SUB - arg1 ds-reg [] MOV - arg1 arg0 SUB + arg1 ds-reg -1 bootstrap-cells [+] MOV + temp-reg ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] arg1 MOV + ds-reg -1 bootstrap-cells [+] arg0 MOV + ds-reg [] temp-reg MOV +] f f f \ rot define-sub-primitive + +[ + arg0 ds-reg [] MOV + arg1 ds-reg -1 bootstrap-cells [+] MOV + temp-reg ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] arg0 MOV + ds-reg -1 bootstrap-cells [+] temp-reg MOV ds-reg [] arg1 MOV -] f f f jit-fixnum-fast jit-define +] f f f \ -rot define-sub-primitive [ - jit-compare - arg1 temp-reg CMOVL ! not equal? + rs-reg bootstrap-cell ADD + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + rs-reg [] arg0 MOV +] f f f \ >r define-sub-primitive + +[ + ds-reg bootstrap-cell ADD + arg0 rs-reg [] MOV + rs-reg bootstrap-cell SUB + ds-reg [] arg0 MOV +] f f f \ r> define-sub-primitive + +! Comparisons +: jit-compare ( insn -- ) + arg1 0 MOV ! load t + arg1 dup [] MOV + temp-reg \ f tag-number MOV ! load f + arg0 ds-reg [] MOV ! load first value + ds-reg bootstrap-cell SUB ! adjust stack pointer + ds-reg [] arg0 CMP ! compare with second value + [ arg1 temp-reg ] dip execute ! move t if true ds-reg [] arg1 MOV ! store -] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define + ; + +: define-jit-compare ( insn word -- ) + [ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip + define-sub-primitive ; + +\ CMOVNE \ eq? define-jit-compare +\ CMOVL \ fixnum>= define-jit-compare +\ CMOVG \ fixnum<= define-jit-compare +\ CMOVLE \ fixnum> define-jit-compare +\ CMOVGE \ fixnum< define-jit-compare + +! Math +: jit-math ( insn -- ) + arg0 ds-reg [] MOV ! load second input + ds-reg bootstrap-cell SUB ! pop stack + arg1 ds-reg [] MOV ! load first input + [ arg1 arg0 ] dip execute ! compute result + ds-reg [] arg1 MOV ! push result + ; + +[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive + +[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive [ - stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame -] f f f jit-epilog jit-define + arg0 ds-reg [] MOV ! load second input + ds-reg bootstrap-cell SUB ! pop stack + arg1 ds-reg [] MOV ! load first input + arg0 tag-bits get SAR ! untag second input + arg0 arg1 IMUL2 ! multiply + ds-reg [] arg1 MOV ! push result +] f f f \ fixnum*fast define-sub-primitive -[ 0 RET ] f f f jit-return jit-define +[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive + +[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive + +[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive + +[ + arg0 ds-reg [] MOV ! load input input + arg0 NOT ! complement + arg0 tag-mask get XOR ! clear tag bits + ds-reg [] arg0 MOV ! save +] f f f \ fixnum-bitnot define-sub-primitive [ "bootstrap.x86" forget-vocab ] with-compilation-unit diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index ac79cce799..6f5277bc35 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -104,6 +104,8 @@ M: object infer-call ] if ] "infer" set-word-prop +\ execute t "no-compile" set-word-prop + \ if [ 3 ensure-values 2 d-tail [ special? ] contains? [ @@ -123,6 +125,8 @@ M: object infer-call [ #dispatch ] infer-branches ] "infer" set-word-prop +\ dispatch t "no-compile" set-word-prop + \ curry [ 2 ensure-values pop-d pop-d swap push-d diff --git a/core/words/words.factor b/core/words/words.factor index 9bf006fa16..1d84acbc14 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -34,7 +34,9 @@ M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; PREDICATE: primitive < word ( obj -- ? ) - def>> [ do-primitive ] tail? ; + [ def>> [ do-primitive ] tail? ] + [ sub-primitive>> >boolean ] + bi or ; M: primitive definer drop \ PRIMITIVE: f ; M: primitive definition drop f ; diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 467db53366..cfec6597c2 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -15,7 +15,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.grids ui.gadgets.theme namespaces.lib assocs.lib vars - rewrite-closures automata ; + rewrite-closures automata math.geometry.rect ; IN: automata.ui diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index e6c97b90dd..cff33c9d19 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces math.order math.vectors math.trig + math.physics.pos + math.physics.vel combinators arrays sequences random vars - combinators.lib ; + combinators.lib + accessors ; IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid pos vel ; +TUPLE: boid < vel ; C: boid @@ -70,7 +73,7 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ; +: distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -81,10 +84,10 @@ VAR: separation-radius ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ; +: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ; : relative-angle ( self other -- angle ) -over boid-vel -rot relative-position angle-between ; +over vel>> -rot relative-position angle-between ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -92,9 +95,9 @@ over boid-vel -rot relative-position angle-between ; : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ; -: average-position ( boids -- pos ) [ boid-pos ] map vaverage ; +: average-position ( boids -- pos ) [ pos>> ] map vaverage ; -: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ; +: average-velocity ( boids -- vel ) [ vel>> ] map vaverage ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -123,7 +126,7 @@ over boid-vel -rot relative-position angle-between ; dup cohesion-neighborhood dup empty? [ 2drop { 0 0 } ] - [ average-position swap boid-pos v- normalize* cohesion-weight> v*n ] + [ average-position swap pos>> v- normalize* cohesion-weight> v*n ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,7 +146,7 @@ over boid-vel -rot relative-position angle-between ; dup separation-neighborhood dup empty? [ 2drop { 0 0 } ] - [ average-position swap boid-pos swap v- normalize* separation-weight> v*n ] + [ average-position swap pos>> swap v- normalize* separation-weight> v*n ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -206,10 +209,10 @@ cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ; +: new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ; : new-vel ( boid -- vel ) - [ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ; + [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ; : wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ; diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index e3c54e0744..ab1f8e5f80 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -19,7 +19,8 @@ USING: combinators.short-circuit kernel namespaces ui.gadgets.packs ui.gadgets.grids ui.gestures - assocs.lib vars rewrite-closures boids ; + assocs.lib vars rewrite-closures boids accessors + math.geometry.rect ; IN: boids.ui @@ -27,9 +28,9 @@ IN: boids.ui ! draw-boid ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: point-a ( boid -- a ) boid-pos ; +: point-a ( boid -- a ) pos>> ; -: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ; +: point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ; : boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ; diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 99968ca3c3..6fcf3c21cd 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -3,7 +3,7 @@ USING: kernel math math.functions math.parser models models.filter models.range models.compose sequences ui ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs -ui.gadgets.sliders ui.render ; +ui.gadgets.sliders ui.render math.geometry.rect ; IN: color-picker ! Simple example demonstrating the use of models. diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index ef2bfd3d55..cc138dad92 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -82,10 +82,10 @@ M: irc-message write-irc [ swap display ] keep ; -TUPLE: irc-editor outstream listener client ; +TUPLE: irc-editor < editor outstream listener client ; : ( pane listener client -- editor ) - [ irc-editor construct-editor + [ irc-editor new-editor swap >>listener swap >>outstream ] dip client>> >>client ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index b7764894d1..d9a0f84b53 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl +jamshred.player jamshred.log kernel math math.constants namespaces +sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds +ui.gestures ui.render math.vectors math.geometry.rect ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; diff --git a/extra/math/geometry/rect/rect-docs.factor b/extra/math/geometry/rect/rect-docs.factor new file mode 100644 index 0000000000..3e21dfe307 --- /dev/null +++ b/extra/math/geometry/rect/rect-docs.factor @@ -0,0 +1,54 @@ +USING: help.markup help.syntax ; + +IN: math.geometry.rect + +HELP: rect +{ $class-description "A rectangle with the following slots:" + { $list + { { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" } + { { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" } + } + "Rectangles are constructed by calling " { $link } " and " { $link } "." +} ; + +HELP: ( loc dim -- rect ) +{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } } +{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ; + +{ } related-words + +HELP: set-rect-dim ( dim rect -- ) +{ $values { "dim" "a pair of integers" } { "rect" rect } } +{ $description "Modifies the dimensions of a rectangle." } +{ $side-effects "rect" } ; + +HELP: rect-bounds +{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } } +{ $description "Outputs the location and dimensions of a rectangle." } ; + +{ rect-bounds rect-extent } related-words + +HELP: ( loc ext -- rect ) +{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } } +{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ; + +HELP: rect-extent +{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } } +{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ; + +HELP: offset-rect +{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } } +{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ; + +HELP: rect-intersect +{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } } +{ $description "Computes the intersection of two rectangles." } ; + +HELP: intersects? +{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } } +{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ; + +HELP: +{ $values { "rect" "a new " { $link rect } } } +{ $description "Creates a rectangle located at the origin with zero dimensions." } ; + diff --git a/extra/math/geometry/rect/rect.factor b/extra/math/geometry/rect/rect.factor new file mode 100644 index 0000000000..51f42c22ca --- /dev/null +++ b/extra/math/geometry/rect/rect.factor @@ -0,0 +1,42 @@ + +USING: kernel arrays math.vectors ; + +IN: math.geometry.rect + +TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; + +: ( -- rect ) rect new ; + +C: rect + +M: array rect-loc ; + +M: array rect-dim drop { 0 0 } ; + +: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; + +: rect-extent ( rect -- loc ext ) rect-bounds over v+ ; + +: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 ) + [ rect-extent ] bi@ swapd ; + +: ( loc ext -- rect ) over [v-] ; + +: offset-rect ( rect loc -- newrect ) + over rect-loc v+ swap rect-dim ; + +: (rect-intersect) ( rect rect -- array array ) + 2rect-extent vmin >r vmax r> ; + +: rect-intersect ( rect1 rect2 -- newrect ) + (rect-intersect) ; + +: intersects? ( rect/point rect -- ? ) + (rect-intersect) [v-] { 0 0 } = ; + +: (rect-union) ( rect rect -- array array ) + 2rect-extent vmax >r vmin r> ; + +: rect-union ( rect1 rect2 -- newrect ) + (rect-union) ; + diff --git a/extra/math/physics/pos/pos.factor b/extra/math/physics/pos/pos.factor new file mode 100644 index 0000000000..1582c42108 --- /dev/null +++ b/extra/math/physics/pos/pos.factor @@ -0,0 +1,5 @@ + +IN: math.physics.pos + +TUPLE: pos pos ; + diff --git a/extra/math/physics/vel/vel.factor b/extra/math/physics/vel/vel.factor new file mode 100644 index 0000000000..5fc815e9b8 --- /dev/null +++ b/extra/math/physics/vel/vel.factor @@ -0,0 +1,7 @@ + +USING: math.physics.pos ; + +IN: math.physics.vel + +TUPLE: vel < pos vel ; + diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index dbf983be62..389dabc0f6 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -1,7 +1,7 @@ ! From http://www.ffconsultancy.com/ocaml/maze/index.html USING: sequences namespaces math math.vectors opengl opengl.gl arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render -math.order ; +math.order math.geometry.rect ; IN: maze : line-width 8 ; diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 147e5b892e..cee0493459 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences strings fry namespaces math assocs shuffle debugger io - vectors arrays math.parser math.order vectors combinators combinators.lib + vectors arrays math.parser math.order vectors combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting combinators.short-circuit combinators.short-circuit.smart ; diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index fb9f321f47..4c9dd787e5 100755 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -10,7 +10,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators.cleave rewrite-closures fry accessors newfx processing.color - processing.gadget ; + processing.gadget math.geometry.rect ; IN: processing diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 1856115863..fb69783975 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences arrays math math.vectors - generalizations vars ; + generalizations vars accessors math.physics.vel ; IN: springies @@ -28,23 +28,29 @@ VAR: gravity ! node ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: node mass elas pos vel force ; +! TUPLE: node mass elas pos vel force ; + +TUPLE: node < vel mass elas force ; C: node -: >>pos ( node pos -- node ) over set-node-pos ; +! : >>pos ( node pos -- node ) over set-node-pos ; -: >>vel ( node vel -- node ) over set-node-vel ; +! : >>vel ( node vel -- node ) over set-node-vel ; -: pos-x ( node -- x ) node-pos first ; -: pos-y ( node -- y ) node-pos second ; -: vel-x ( node -- y ) node-vel first ; -: vel-y ( node -- y ) node-vel second ; +: node-vel ( node -- vel ) vel>> ; -: >>pos-x ( node x -- node ) over node-pos set-first ; -: >>pos-y ( node y -- node ) over node-pos set-second ; -: >>vel-x ( node x -- node ) over node-vel set-first ; -: >>vel-y ( node y -- node ) over node-vel set-second ; +: set-node-vel ( vel node -- ) swap >>vel drop ; + +: pos-x ( node -- x ) pos>> first ; +: pos-y ( node -- y ) pos>> second ; +: vel-x ( node -- y ) vel>> first ; +: vel-y ( node -- y ) vel>> second ; + +: >>pos-x ( node x -- node ) over pos>> set-first ; +: >>pos-y ( node y -- node ) over pos>> set-second ; +: >>vel-x ( node x -- node ) over vel>> set-first ; +: >>vel-y ( node y -- node ) over vel>> set-second ; : apply-force ( node vec -- ) over node-force v+ swap set-node-force ; @@ -61,7 +67,7 @@ TUPLE: spring rest-length k damp node-a node-b ; C: spring : end-points ( spring -- b-pos a-pos ) - [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ; + [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ; : spring-length ( spring -- length ) end-points v- norm ; @@ -112,10 +118,10 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-a ( spring -- vel ) - [ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ; + [ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ; : unit-vec-b->a ( spring -- vec ) - [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ; + [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ; : relative-velocity-along-spring-a ( spring -- vel ) [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; @@ -126,10 +132,10 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : relative-velocity-b ( spring -- vel ) - [ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ; + [ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ; : unit-vec-a->b ( spring -- vec ) - [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ; + [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ; : relative-velocity-along-spring-b ( spring -- vel ) [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; @@ -210,9 +216,9 @@ C: spring : calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; : new-vel ( node -- vel ) - [ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ; + [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ; -: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ; +: new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ; : iterate-node ( node -- ) dup new-pos >>pos @@ -231,16 +237,21 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : mass ( id x y x-vel y-vel mass elas -- ) - 7 nrot drop - 6 nrot 6 nrot 2array - 5 nrot 5 nrot 2array - 0 0 2array - nodes> swap suffix >nodes ; + node new + swap >>elas + swap >>mass + -rot 2array >>vel + -rot 2array >>pos + 0 0 2array >>force + nodes> swap suffix >nodes + drop ; : spng ( id id-a id-b k damp rest-length -- ) - 6 nrot drop - -rot - 5 nrot node-id - 5 nrot node-id - - springs> swap suffix >springs ; + spring new + swap >>rest-length + swap >>damp + swap >>k + swap node-id >>node-b + swap node-id >>node-a + springs> swap suffix >springs + drop ; \ No newline at end of file diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 8aabe6b70b..365632e974 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -1,16 +1,16 @@ USING: kernel namespaces threads sequences math math.vectors opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate - fry rewrite-closures vars springies ; + fry rewrite-closures vars springies accessors math.geometry.rect ; IN: springies.ui ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; +: draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; : draw-spring ( spring -- ) - [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ; + [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ; : draw-nodes ( -- ) nodes> [ draw-node ] each ; diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index c2f874598c..d01cec3790 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui -tetris.game tetris.gl sequences system math math.parser namespaces ; +tetris.game tetris.gl sequences system math math.parser namespaces +math.geometry.rect ; IN: tetris TUPLE: tetris-gadget tetris alarm ; diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor index dd9510405f..132a11f4a6 100755 --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -6,7 +6,7 @@ TUPLE: foo bar ; C: foo [ 2 ] [ 2 T{ foo } dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test -[ T{ foo f 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test +[ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ T{ foo f 3 } t ] [ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 6a31dac808..63e7541c95 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -1,35 +1,26 @@ ! Copyright (C) 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: splitting grouping classes.tuple classes math kernel -sequences arrays ; +sequences arrays accessors ; IN: tuple-arrays -TUPLE: tuple-array example ; - -: prepare-example ( tuple -- seq n ) - dup class over delegate [ 1array ] [ f 2array ] if - swap tuple>array length over length - ; +TUPLE: tuple-array seq class ; : ( length example -- tuple-array ) - prepare-example [ rot * { } new-sequence ] keep - tuple-array construct-delegate - [ set-tuple-array-example ] keep ; - -: reconstruct ( seq example -- tuple ) - prepend >tuple ; + [ tuple>array length 1- [ * { } new-sequence ] keep ] + [ class ] bi tuple-array boa ; M: tuple-array nth - [ delegate nth ] keep - tuple-array-example reconstruct ; + [ seq>> nth ] [ class>> ] bi prefix >tuple ; -: deconstruct ( tuple example -- seq ) - >r tuple>array r> length tail-slice ; +: deconstruct ( tuple -- seq ) + tuple>array 1 tail ; M: tuple-array set-nth ( elt n seq -- ) - tuck >r >r tuple-array-example deconstruct r> r> - delegate set-nth ; + >r >r deconstruct r> r> seq>> set-nth ; -M: tuple-array new-sequence tuple-array-example >tuple ; +M: tuple-array new-sequence + class>> new ; : >tuple-array ( seq -- tuple-array/seq ) dup empty? [ @@ -39,4 +30,6 @@ M: tuple-array new-sequence tuple-array-example >tuple ; M: tuple-array like drop dup tuple-array? [ >tuple-array ] unless ; +M: tuple-array length seq>> length ; + INSTANCE: tuple-array sequence diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index bf28740ecc..0085376eaa 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds -ui.cocoa.views core-foundation threads ; +ui.cocoa.views core-foundation threads math.geometry.rect ; IN: ui.cocoa TUPLE: handle view window ; diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 68db5954d5..3bacad20b4 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -core-foundation threads combinators ; +core-foundation threads combinators math.geometry.rect ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 219a970943..93a8d271af 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences models ui.gadgets ; +USING: accessors kernel sequences models ui.gadgets math.geometry.rect ; IN: ui.gadgets.books TUPLE: book < gadget ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 55d1993b1d..2c232392ce 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays ui.gadgets kernel math -namespaces vectors sequences math.vectors ; +namespaces vectors sequences math.vectors math.geometry.rect ; IN: ui.gadgets.borders TUPLE: border < gadget diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 96a89e8aa6..a855a6d93e 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -6,7 +6,7 @@ classes.tuple opengl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render ; +ui.render math.geometry.rect ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 1732d404ca..8b0244900a 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -5,7 +5,8 @@ namespaces opengl opengl.gl sequences strings io.styles math.vectors sorting colors combinators assocs math.order ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ; +ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures +math.geometry.rect ; IN: ui.gadgets.editors TUPLE: editor < gadget diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor index a288f74f64..7d77db24cc 100644 --- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -1,7 +1,7 @@ USING: kernel alien.c-types combinators sequences splitting grouping opengl.gl ui.gadgets ui.render - math math.vectors accessors ; + math math.vectors accessors math.geometry.rect ; IN: ui.gadgets.frame-buffer diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 096d916a9b..717323c69a 100644 --- a/extra/ui/gadgets/frames/frames.factor +++ b/extra/ui/gadgets/frames/frames.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic kernel math namespaces sequences words -splitting grouping math.vectors ui.gadgets.grids ui.gadgets ; +splitting grouping math.vectors ui.gadgets.grids ui.gadgets +math.geometry.rect ; IN: ui.gadgets.frames ! A frame arranges gadgets in a 3x3 grid, where the center diff --git a/extra/ui/gadgets/gadgets-docs.factor b/extra/ui/gadgets/gadgets-docs.factor index 8093aa5dc5..b9d12847be 100755 --- a/extra/ui/gadgets/gadgets-docs.factor +++ b/extra/ui/gadgets/gadgets-docs.factor @@ -1,53 +1,7 @@ USING: help.markup help.syntax opengl kernel strings -classes.tuple classes quotations models ; + classes.tuple classes quotations models math.geometry.rect ; IN: ui.gadgets -HELP: rect -{ $class-description "A rectangle with the following slots:" - { $list - { { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" } - { { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" } - } - "Rectangles are constructed by calling " { $link } " and " { $link } "." -} ; - -HELP: ( loc dim -- rect ) -{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } } -{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ; - -{ } related-words - -HELP: set-rect-dim ( dim rect -- ) -{ $values { "dim" "a pair of integers" } { "rect" rect } } -{ $description "Modifies the dimensions of a rectangle. To resize a gadget, use " { $link set-gadget-dim } " or " { $link set-layout-dim } " instead." } -{ $side-effects "rect" } ; - -HELP: rect-bounds -{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } } -{ $description "Outputs the location and dimensions of a rectangle." } ; - -{ rect-bounds rect-extent } related-words - -HELP: ( loc ext -- rect ) -{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } } -{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ; - -HELP: rect-extent -{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } } -{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ; - -HELP: offset-rect -{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } } -{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ; - -HELP: rect-intersect -{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } } -{ $description "Computes the intersection of two rectangles." } ; - -HELP: intersects? -{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } } -{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ; - HELP: gadget-child { $values { "gadget" gadget } { "child" gadget } } { $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ; @@ -57,10 +11,6 @@ HELP: nth-gadget { $description "Outputs the " { $snippet "n" } "th child of the gadget." } { $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ; -HELP: -{ $values { "rect" "a new " { $link rect } } } -{ $description "Creates a rectangle located at the origin with zero dimensions." } ; - HELP: { $values { "gadget" "a new " { $link gadget } } } { $description "Creates a new gadget." } ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 5bfb5a1b05..a274dc2392 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,51 +1,16 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables kernel models math namespaces -sequences quotations math.vectors combinators sorting vectors -dlists dequeues models threads concurrency.flags math.order ; + sequences quotations math.vectors combinators sorting vectors + dlists dequeues models threads concurrency.flags + math.order math.geometry.rect ; + IN: ui.gadgets SYMBOL: ui-notify-flag : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; -TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; - -: ( -- rect ) rect new ; - -C: rect - -M: array rect-loc ; - -M: array rect-dim drop { 0 0 } ; - -: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ; - -: rect-extent ( rect -- loc ext ) rect-bounds over v+ ; - -: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 ) - [ rect-extent ] bi@ swapd ; - -: ( loc ext -- rect ) over [v-] ; - -: offset-rect ( rect loc -- newrect ) - over rect-loc v+ swap rect-dim ; - -: (rect-intersect) ( rect rect -- array array ) - 2rect-extent vmin >r vmax r> ; - -: rect-intersect ( rect1 rect2 -- newrect ) - (rect-intersect) ; - -: intersects? ( rect/point rect -- ? ) - (rect-intersect) [v-] { 0 0 } = ; - -: (rect-union) ( rect rect -- array array ) - 2rect-extent vmax >r vmin r> ; - -: rect-union ( rect1 rect2 -- newrect ) - (rect-union) ; - TUPLE: gadget < rect pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index 533116824b..d0cedc985b 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces opengl opengl.gl sequences -math.vectors ui.gadgets ui.gadgets.grids ui.render ; +math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ; IN: ui.gadgets.grid-lines TUPLE: grid-lines color ; diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index 70aee4d1e3..b539934771 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences words io -io.streams.string math.vectors ui.gadgets columns accessors ; +io.streams.string math.vectors ui.gadgets columns accessors +math.geometry.rect ; IN: ui.gadgets.grids TUPLE: grid < gadget diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index 418dd3b7c6..c74f6676ad 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces math.vectors ui.gadgets -ui.gadgets.packs accessors ; +ui.gadgets.packs accessors math.geometry.rect ; IN: ui.gadgets.incremental ! Incremental layout allows adding lines to panes to be O(1). diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 2b50453cf4..776814853f 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -4,7 +4,7 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels ui.gadgets.scrollers kernel sequences models opengl math math.order namespaces ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs -math.vectors classes.tuple ; +math.vectors classes.tuple math.geometry.rect ; IN: ui.gadgets.lists TUPLE: list < pack index presenter color hook ; diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor index 66dbb05d66..3e1145a8b6 100644 --- a/extra/ui/gadgets/menus/menus.factor +++ b/extra/ui/gadgets/menus/menus.factor @@ -3,7 +3,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic hashtables kernel math models namespaces opengl sequences math.vectors -ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ; +ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors +math.geometry.rect ; IN: ui.gadgets.menus : menu-loc ( world menu -- loc ) diff --git a/extra/ui/gadgets/packs/packs.factor b/extra/ui/gadgets/packs/packs.factor index 00f27af270..7ae222c279 100755 --- a/extra/ui/gadgets/packs/packs.factor +++ b/extra/ui/gadgets/packs/packs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences ui.gadgets kernel math math.functions -math.vectors namespaces math.order accessors ; +math.vectors namespaces math.order accessors math.geometry.rect ; IN: ui.gadgets.packs TUPLE: pack < gadget diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 87eec35871..973c8c5725 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines classes.tuple models continuations -destructors accessors ; +destructors accessors math.geometry.rect ; IN: ui.gadgets.panes TUPLE: pane < pack diff --git a/extra/ui/gadgets/paragraphs/paragraphs.factor b/extra/ui/gadgets/paragraphs/paragraphs.factor index 12382be9cd..1946ff6db6 100644 --- a/extra/ui/gadgets/paragraphs/paragraphs.factor +++ b/extra/ui/gadgets/paragraphs/paragraphs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math -namespaces sequences math.order ; +namespaces sequences math.order math.geometry.rect ; IN: ui.gadgets.paragraphs ! A word break gadget diff --git a/extra/ui/gadgets/scrollers/scrollers-docs.factor b/extra/ui/gadgets/scrollers/scrollers-docs.factor index ee82339f33..3554c735a7 100755 --- a/extra/ui/gadgets/scrollers/scrollers-docs.factor +++ b/extra/ui/gadgets/scrollers/scrollers-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports -ui.gadgets.sliders ; +ui.gadgets.sliders math.geometry.rect ; IN: ui.gadgets.scrollers HELP: scroller diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 8cac3f4400..1fe3c606bb 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math namespaces sequences models models.range models.compose -combinators math.vectors classes.tuple ; +combinators math.vectors classes.tuple math.geometry.rect ; IN: ui.gadgets.scrollers TUPLE: scroller < frame viewport x y follows ; diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index da18dea142..b5d8862359 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids math.order ui.gadgets.theme ui.render kernel math namespaces sequences vectors models models.range math.vectors math.functions -quotations colors ; +quotations colors math.geometry.rect ; IN: ui.gadgets.sliders TUPLE: elevator < gadget direction ; diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor index 1b4f633609..7c663f88e3 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -51,6 +51,6 @@ DEFER: (del-page) tabbed new-frame [ g 0 >>model 1 >>fill [ >>toggler ] keep swap @left grid-add - [ keys g swap >>names ] + [ keys >vector g swap >>names ] [ values g model>> [ >>content ] keep swap @center grid-add ] bi g redo-toggler g ] with-gadget ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index f9276fd1a1..5de9b9d366 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel math namespaces -sequences words math.vectors ui.gadgets ui.gadgets.packs ; +sequences words math.vectors ui.gadgets ui.gadgets.packs math.geometry.rect ; IN: ui.gadgets.tracks TUPLE: track < pack sizes ; diff --git a/extra/ui/gadgets/viewports/viewports.factor b/extra/ui/gadgets/viewports/viewports.factor index 2e7e130404..100d6c8a39 100755 --- a/extra/ui/gadgets/viewports/viewports.factor +++ b/extra/ui/gadgets/viewports/viewports.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: ui.gadgets.viewports USING: accessors arrays ui.gadgets ui.gadgets.borders -kernel math namespaces sequences models math.vectors ; +kernel math namespaces sequences models math.vectors math.geometry.rect ; : viewport-gap { 3 3 } ; inline diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index 7064045cc4..dc4debd900 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -debugger ; +debugger math.geometry.rect ; IN: ui.gadgets.worlds TUPLE: world < track diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor index d48d7c99d9..0133b7bb1c 100755 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets ui.gestures help.markup help.syntax -kernel classes strings opengl.gl models ; +kernel classes strings opengl.gl models math.geometry.rect ; IN: ui.render HELP: gadget diff --git a/extra/ui/render/render.factor b/extra/ui/render/render.factor index 8f40bec1c3..6e9a4778a7 100644 --- a/extra/ui/render/render.factor +++ b/extra/ui/render/render.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays hashtables io kernel math namespaces opengl opengl.gl opengl.glu sequences strings io.styles vectors -combinators math.vectors ui.gadgets colors math.order ; +combinators math.vectors ui.gadgets colors +math.order math.geometry.rect ; IN: ui.render SYMBOL: clip diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 1a541090c5..72cb2c557e 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax strings quotations debugger io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds -ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ; +ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ; IN: ui HELP: windows diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 231dd7f8a5..a210287439 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii -math.bitfields locals symbols accessors ; +math.bitfields locals symbols accessors math.geometry.rect ; IN: ui.windows SINGLETON: windows-ui-backend diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 35f22ec64f..b75daf89fa 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -6,7 +6,7 @@ assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.ascii io.encodings.utf8 combinators debugger command-line qualified -math.vectors classes.tuple opengl.gl threads ; +math.vectors classes.tuple opengl.gl threads math.geometry.rect ; QUALIFIED: system IN: ui.x11 diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 6233b4a14f..b1a3561974 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -6,7 +6,6 @@ and the callstack top is passed in EDX */ #define ARG0 %eax #define ARG1 %edx -#define XT_REG %ecx #define STACK_REG %esp #define DS_REG %esi #define RETURN_REG %eax @@ -22,9 +21,6 @@ and the callstack top is passed in EDX */ pop %ebx #define QUOT_XT_OFFSET 9 -#define PROFILING_OFFSET 25 -#define WORD_DEF_OFFSET 13 -#define WORD_XT_OFFSET 29 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 4e8faa18de..57bfcee87b 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -2,7 +2,6 @@ #define ARG0 %rdi #define ARG1 %rsi -#define XT_REG %rcx #define STACK_REG %rsp #define DS_REG %r14 #define RETURN_REG %rax @@ -22,9 +21,6 @@ pop %rbx #define QUOT_XT_OFFSET 21 -#define PROFILING_OFFSET 53 -#define WORD_DEF_OFFSET 29 -#define WORD_XT_OFFSET 61 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 5c0a105a55..e8e2af7b25 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,5 +1,3 @@ -#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0) - DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE push ARG0 /* Save quot */ @@ -14,20 +12,9 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): POP_NONVOLATILE ret -DEF(F_FASTCALL void,primitive_call,(void)): - mov (DS_REG),ARG0 /* Load quotation from data stack */ - sub $CELL_SIZE,DS_REG /* Pop data stack */ - JUMP_QUOT - -/* Don't mess up EDX, it's the callstack top parameter to primitives. */ -DEF(F_FASTCALL void,primitive_execute,(void)): - mov (DS_REG),ARG0 /* Load word from data stack */ - sub $CELL_SIZE,DS_REG /* Pop data stack */ - jmp *WORD_XT_OFFSET(ARG0) /* Load word-xt slot */ - DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): mov ARG1,STACK_REG /* rewind_to */ - JUMP_QUOT + jmp *QUOT_XT_OFFSET(ARG0) DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): mov STACK_REG,ARG1 /* Save stack pointer */ @@ -39,7 +26,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): pop ARG1 /* OK to clobber ARG1 here */ pop ARG1 pop ARG1 - JUMP_QUOT /* Call the quotation */ + jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ #ifdef WINDOWS .section .drectve diff --git a/vm/layouts.h b/vm/layouts.h index 06a37672a7..7ebfe50dd4 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -129,6 +129,8 @@ typedef struct { CELL compiledp; /* TAGGED call count for profiling */ CELL counter; + /* TAGGED machine code for sub-primitive */ + CELL subprimitive; /* UNTAGGED execution token: jump here to execute word */ XT xt; /* UNTAGGED compiled code block */ diff --git a/vm/math.c b/vm/math.c index 8c4e7d537a..c1e13951dc 100644 --- a/vm/math.c +++ b/vm/math.c @@ -35,33 +35,18 @@ DEFINE_PRIMITIVE(float_to_fixnum) F_FIXNUM y = untag_fixnum_fast(dpop()); \ F_FIXNUM x = untag_fixnum_fast(dpop()); -/* The fixnum arithmetic operations defined in C are relatively slow. -The Factor compiler has optimized assembly intrinsics for some of these -operations. */ DEFINE_PRIMITIVE(fixnum_add) { POP_FIXNUMS(x,y) box_signed_cell(x + y); } -DEFINE_PRIMITIVE(fixnum_add_fast) -{ - POP_FIXNUMS(x,y) - dpush(tag_fixnum(x + y)); -} - DEFINE_PRIMITIVE(fixnum_subtract) { POP_FIXNUMS(x,y) box_signed_cell(x - y); } -DEFINE_PRIMITIVE(fixnum_subtract_fast) -{ - POP_FIXNUMS(x,y) - dpush(tag_fixnum(x - y)); -} - /* Multiply two integers, and trap overflow. Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */ DEFINE_PRIMITIVE(fixnum_multiply) @@ -87,12 +72,6 @@ DEFINE_PRIMITIVE(fixnum_multiply) } } -DEFINE_PRIMITIVE(fixnum_multiply_fast) -{ - POP_FIXNUMS(x,y) - dpush(tag_fixnum(x * y)); -} - DEFINE_PRIMITIVE(fixnum_divint) { POP_FIXNUMS(x,y) @@ -112,24 +91,6 @@ DEFINE_PRIMITIVE(fixnum_mod) dpush(tag_fixnum(x % y)); } -DEFINE_PRIMITIVE(fixnum_and) -{ - POP_FIXNUMS(x,y) - dpush(tag_fixnum(x & y)); -} - -DEFINE_PRIMITIVE(fixnum_or) -{ - POP_FIXNUMS(x,y) - dpush(tag_fixnum(x | y)); -} - -DEFINE_PRIMITIVE(fixnum_xor) -{ - POP_FIXNUMS(x,y) - dpush(tag_fixnum(x ^ y)); -} - /* * Note the hairy overflow check. * If we're shifting right by n bits, we won't overflow as long as none of the @@ -172,35 +133,6 @@ DEFINE_PRIMITIVE(fixnum_shift_fast) dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y))); } -DEFINE_PRIMITIVE(fixnum_less) -{ - POP_FIXNUMS(x,y) - box_boolean(x < y); -} - -DEFINE_PRIMITIVE(fixnum_lesseq) -{ - POP_FIXNUMS(x,y) - box_boolean(x <= y); -} - -DEFINE_PRIMITIVE(fixnum_greater) -{ - POP_FIXNUMS(x,y) - box_boolean(x > y); -} - -DEFINE_PRIMITIVE(fixnum_greatereq) -{ - POP_FIXNUMS(x,y) - box_boolean(x >= y); -} - -DEFINE_PRIMITIVE(fixnum_not) -{ - drepl(tag_fixnum(~untag_fixnum_fast(dpeek()))); -} - /* Bignums */ DEFINE_PRIMITIVE(fixnum_to_bignum) { diff --git a/vm/math.h b/vm/math.h index d82a373571..6f81ece8a8 100644 --- a/vm/math.h +++ b/vm/math.h @@ -11,23 +11,12 @@ DECLARE_PRIMITIVE(float_to_fixnum); DECLARE_PRIMITIVE(fixnum_add); DECLARE_PRIMITIVE(fixnum_subtract); -DECLARE_PRIMITIVE(fixnum_add_fast); -DECLARE_PRIMITIVE(fixnum_subtract_fast); DECLARE_PRIMITIVE(fixnum_multiply); -DECLARE_PRIMITIVE(fixnum_multiply_fast); DECLARE_PRIMITIVE(fixnum_divint); DECLARE_PRIMITIVE(fixnum_divmod); DECLARE_PRIMITIVE(fixnum_mod); -DECLARE_PRIMITIVE(fixnum_and); -DECLARE_PRIMITIVE(fixnum_or); -DECLARE_PRIMITIVE(fixnum_xor); DECLARE_PRIMITIVE(fixnum_shift); DECLARE_PRIMITIVE(fixnum_shift_fast); -DECLARE_PRIMITIVE(fixnum_less); -DECLARE_PRIMITIVE(fixnum_lesseq); -DECLARE_PRIMITIVE(fixnum_greater); -DECLARE_PRIMITIVE(fixnum_greatereq); -DECLARE_PRIMITIVE(fixnum_not); CELL bignum_zero; CELL bignum_pos_one; diff --git a/vm/primitives.c b/vm/primitives.c index d670b41897..b5d9403342 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -1,8 +1,6 @@ #include "master.h" void *primitives[] = { - primitive_execute, - primitive_call, primitive_bignum_to_fixnum, primitive_float_to_fixnum, primitive_fixnum_to_bignum, @@ -18,24 +16,13 @@ void *primitives[] = { primitive_bits_double, primitive_from_rect, primitive_fixnum_add, - primitive_fixnum_add_fast, primitive_fixnum_subtract, - primitive_fixnum_subtract_fast, primitive_fixnum_multiply, - primitive_fixnum_multiply_fast, primitive_fixnum_divint, primitive_fixnum_mod, primitive_fixnum_divmod, - primitive_fixnum_and, - primitive_fixnum_or, - primitive_fixnum_xor, - primitive_fixnum_not, primitive_fixnum_shift, primitive_fixnum_shift_fast, - primitive_fixnum_less, - primitive_fixnum_lesseq, - primitive_fixnum_greater, - primitive_fixnum_greatereq, primitive_bignum_eq, primitive_bignum_add, primitive_bignum_subtract, @@ -67,25 +54,6 @@ void *primitives[] = { primitive_float_greatereq, primitive_word, primitive_word_xt, - primitive_drop, - primitive_2drop, - primitive_3drop, - primitive_dup, - primitive_2dup, - primitive_3dup, - primitive_rot, - primitive__rot, - primitive_dupd, - primitive_swapd, - primitive_nip, - primitive_2nip, - primitive_tuck, - primitive_over, - primitive_pick, - primitive_swap, - primitive_to_r, - primitive_from_r, - primitive_eq, primitive_getenv, primitive_setenv, primitive_existsp, @@ -105,7 +73,6 @@ void *primitives[] = { primitive_code_room, primitive_os_env, primitive_millis, - primitive_tag, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, @@ -140,7 +107,6 @@ void *primitives[] = { primitive_set_alien_cell, primitive_throw, primitive_alien_address, - primitive_slot, primitive_set_slot, primitive_string_nth, primitive_set_string_nth, diff --git a/vm/quotations.c b/vm/quotations.c index 7eab41688a..2d54f23a6f 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -1,8 +1,38 @@ #include "master.h" -/* Simple JIT compiler. This is one of the two compilers implementing Factor; -the second one is written in Factor and performs a lot of optimizations. -See core/compiler/compiler.factor */ +/* Simple non-optimizing compiler. + +This is one of the two compilers implementing Factor; the second one is written +in Factor and performs advanced optimizations. See core/compiler/compiler.factor. + +The non-optimizing compiler compiles a quotation at a time by concatenating +machine code chunks; prolog, epilog, call word, jump to word, etc. These machine +code chunks are generated from Factor code in core/cpu/.../bootstrap.factor. + +It actually does do a little bit of very simple optimization: + +1) Tail call optimization. + +2) If a quotation is determined to not call any other words (except for a few +special words which are open-coded, see below), then no prolog/epilog is +generated. + +3) When in tail position and immediately preceded by literal arguments, the +'if' and 'dispatch' conditionals are generated inline, instead of as a call to +the 'if' word. + +4) When preceded by an array, calls to the 'declare' word are optimized out +entirely. This word is only used by the optimizing compiler, and with the +non-optimizing compiler it would otherwise just decrease performance to have to +push the array and immediately drop it after. + +5) Sub-primitives are primitive words which are implemented in assembly and not +in the VM. They are open-coded and no subroutine call is generated. This +includes stack shufflers, some fixnum arithmetic words, and words such as tag, +slot and eq?. A primitive call is relatively expensive (two subroutine calls) +so this results in a big speedup for relatively little effort. + +*/ bool jit_primitive_call_p(F_ARRAY *array, CELL i) { return (i + 2) == array_capacity(array) @@ -32,15 +62,15 @@ bool jit_ignore_declare_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; } -F_ARRAY *code_to_emit(CELL name) +F_ARRAY *code_to_emit(CELL code) { - return untag_object(array_nth(untag_object(userenv[name]),0)); + return untag_object(array_nth(untag_object(code),0)); } -F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length, +F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, CELL rel_argument, bool *rel_p) { - F_ARRAY *quadruple = untag_object(userenv[name]); + F_ARRAY *quadruple = untag_object(code); CELL rel_class = array_nth(quadruple,1); CELL rel_type = array_nth(quadruple,2); CELL offset = array_nth(quadruple,3); @@ -82,20 +112,9 @@ bool jit_stack_frame_p(F_ARRAY *array) CELL obj = array_nth(array,i); if(type_of(obj) == WORD_TYPE) { - if(obj != userenv[JIT_TAG_WORD] - && obj != userenv[JIT_EQP_WORD] - && obj != userenv[JIT_SLOT_WORD] - && obj != userenv[JIT_DROP_WORD] - && obj != userenv[JIT_DUP_WORD] - && obj != userenv[JIT_TO_R_WORD] - && obj != userenv[JIT_FROM_R_WORD] - && obj != userenv[JIT_SWAP_WORD] - && obj != userenv[JIT_OVER_WORD] - && obj != userenv[JIT_FIXNUM_MINUS_WORD] - && obj != userenv[JIT_FIXNUM_GE_WORD]) - { + F_WORD *word = untag_object(obj); + if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD]) return true; - } } } @@ -139,7 +158,7 @@ void jit_compile(CELL quot, bool relocate) bool stack_frame = jit_stack_frame_p(untag_object(array)); if(stack_frame) - EMIT(JIT_PROLOG,0); + EMIT(userenv[JIT_PROLOG],0); CELL i; CELL length = array_capacity(untag_object(array)); @@ -154,84 +173,44 @@ void jit_compile(CELL quot, bool relocate) switch(type_of(obj)) { case WORD_TYPE: + word = untag_object(obj); + /* Intrinsics */ - if(obj == userenv[JIT_TAG_WORD]) + if(word->subprimitive != F) { - EMIT(JIT_TAG,0); - } - else if(obj == userenv[JIT_EQP_WORD]) - { - GROWABLE_ARRAY_ADD(literals,T); - EMIT(JIT_EQP,literals_count - 1); - } - else if(obj == userenv[JIT_SLOT_WORD]) - { - EMIT(JIT_SLOT,0); - } - else if(obj == userenv[JIT_DROP_WORD]) - { - EMIT(JIT_DROP,0); - } - else if(obj == userenv[JIT_DUP_WORD]) - { - EMIT(JIT_DUP,0); - } - else if(obj == userenv[JIT_TO_R_WORD]) - { - EMIT(JIT_TO_R,0); - } - else if(obj == userenv[JIT_FROM_R_WORD]) - { - EMIT(JIT_FROM_R,0); - } - else if(obj == userenv[JIT_SWAP_WORD]) - { - EMIT(JIT_SWAP,0); - } - else if(obj == userenv[JIT_OVER_WORD]) - { - EMIT(JIT_OVER,0); - } - else if(obj == userenv[JIT_FIXNUM_MINUS_WORD]) - { - EMIT(JIT_FIXNUM_MINUS,0); - } - else if(obj == userenv[JIT_FIXNUM_GE_WORD]) - { - GROWABLE_ARRAY_ADD(literals,T); - EMIT(JIT_FIXNUM_GE,literals_count - 1); + if(array_nth(untag_object(word->subprimitive),1) != F) + { + GROWABLE_ARRAY_ADD(literals,T); + } + + EMIT(word->subprimitive,literals_count - 1); } else { - /* Emit the epilog before the primitive call gate - so that we save the C stack pointer minus the - current stack frame. */ - word = untag_object(obj); - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); if(i == length - 1) { if(stack_frame) - EMIT(JIT_EPILOG,0); + EMIT(userenv[JIT_EPILOG],0); - EMIT(JIT_WORD_JUMP,literals_count - 1); + EMIT(userenv[JIT_WORD_JUMP],literals_count - 1); tail_call = true; } else - EMIT(JIT_WORD_CALL,literals_count - 1); + EMIT(userenv[JIT_WORD_CALL],literals_count - 1); } break; case WRAPPER_TYPE: wrapper = untag_object(obj); GROWABLE_ARRAY_ADD(literals,wrapper->object); - EMIT(JIT_PUSH_LITERAL,literals_count - 1); + EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - EMIT(JIT_PRIMITIVE,to_fixnum(obj)); + EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj)); i++; @@ -242,11 +221,11 @@ void jit_compile(CELL quot, bool relocate) if(jit_fast_if_p(untag_object(array),i)) { if(stack_frame) - EMIT(JIT_EPILOG,0); + EMIT(userenv[JIT_EPILOG],0); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); - EMIT(JIT_IF_JUMP,literals_count - 2); + EMIT(userenv[JIT_IF_JUMP],literals_count - 2); i += 2; @@ -257,10 +236,10 @@ void jit_compile(CELL quot, bool relocate) if(jit_fast_dispatch_p(untag_object(array),i)) { if(stack_frame) - EMIT(JIT_EPILOG,0); + EMIT(userenv[JIT_EPILOG],0); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(JIT_DISPATCH,literals_count - 1); + EMIT(userenv[JIT_DISPATCH],literals_count - 1); i++; @@ -274,7 +253,7 @@ void jit_compile(CELL quot, bool relocate) } default: GROWABLE_ARRAY_ADD(literals,obj); - EMIT(JIT_PUSH_LITERAL,literals_count - 1); + EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); break; } } @@ -282,9 +261,9 @@ void jit_compile(CELL quot, bool relocate) if(!tail_call) { if(stack_frame) - EMIT(JIT_EPILOG,0); + EMIT(userenv[JIT_EPILOG],0); - EMIT(JIT_RETURN,0); + EMIT(userenv[JIT_RETURN],0); } GROWABLE_ARRAY_TRIM(code); @@ -330,7 +309,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) bool stack_frame = jit_stack_frame_p(untag_object(array)); if(stack_frame) - COUNT(JIT_PROLOG,0) + COUNT(userenv[JIT_PROLOG],0) CELL i; CELL length = array_capacity(untag_object(array)); @@ -339,55 +318,34 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) for(i = 0; i < length; i++) { CELL obj = array_nth(untag_object(array),i); + F_WORD *word; switch(type_of(obj)) { case WORD_TYPE: /* Intrinsics */ - if(obj == userenv[JIT_TAG_WORD]) - COUNT(JIT_TAG,i) - else if(obj == userenv[JIT_EQP_WORD]) - COUNT(JIT_EQP,i) - else if(obj == userenv[JIT_SLOT_WORD]) - COUNT(JIT_SLOT,i) - else if(obj == userenv[JIT_DROP_WORD]) - COUNT(JIT_DROP,i) - else if(obj == userenv[JIT_DUP_WORD]) - COUNT(JIT_DUP,i) - else if(obj == userenv[JIT_TO_R_WORD]) - COUNT(JIT_TO_R,i) - else if(obj == userenv[JIT_FROM_R_WORD]) - COUNT(JIT_FROM_R,i) - else if(obj == userenv[JIT_SWAP_WORD]) - COUNT(JIT_SWAP,i) - else if(obj == userenv[JIT_OVER_WORD]) - COUNT(JIT_OVER,i) - else if(obj == userenv[JIT_FIXNUM_MINUS_WORD]) - COUNT(JIT_FIXNUM_MINUS,i) - else if(obj == userenv[JIT_FIXNUM_GE_WORD]) - COUNT(JIT_FIXNUM_GE,i) - else + word = untag_object(obj); + if(word->subprimitive != F) + COUNT(word->subprimitive,i) + else if(i == length - 1) { - if(i == length - 1) - { - if(stack_frame) - COUNT(JIT_EPILOG,i); - - COUNT(JIT_WORD_JUMP,i) - - tail_call = true; - } - else - COUNT(JIT_WORD_CALL,i) + if(stack_frame) + COUNT(userenv[JIT_EPILOG],i); + + COUNT(userenv[JIT_WORD_JUMP],i) + + tail_call = true; } + else + COUNT(userenv[JIT_WORD_CALL],i) break; case WRAPPER_TYPE: - COUNT(JIT_PUSH_LITERAL,i) + COUNT(userenv[JIT_PUSH_LITERAL],i) break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - COUNT(JIT_PRIMITIVE,i); + COUNT(userenv[JIT_PRIMITIVE],i); i++; @@ -398,11 +356,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(jit_fast_if_p(untag_object(array),i)) { if(stack_frame) - COUNT(JIT_EPILOG,i) + COUNT(userenv[JIT_EPILOG],i) i += 2; - COUNT(JIT_IF_JUMP,i) + COUNT(userenv[JIT_IF_JUMP],i) tail_call = true; break; @@ -411,11 +369,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(jit_fast_dispatch_p(untag_object(array),i)) { if(stack_frame) - COUNT(JIT_EPILOG,i) + COUNT(userenv[JIT_EPILOG],i) i++; - COUNT(JIT_DISPATCH,i) + COUNT(userenv[JIT_DISPATCH],i) tail_call = true; break; @@ -429,7 +387,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) break; } default: - COUNT(JIT_PUSH_LITERAL,i) + COUNT(userenv[JIT_PUSH_LITERAL],i) break; } } @@ -437,9 +395,9 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(!tail_call) { if(stack_frame) - COUNT(JIT_EPILOG,length) + COUNT(userenv[JIT_EPILOG],length) - COUNT(JIT_RETURN,length) + COUNT(userenv[JIT_RETURN],length) } return -1; diff --git a/vm/run.c b/vm/run.c index ae0c91d9e6..c4a3e115c1 100755 --- a/vm/run.c +++ b/vm/run.c @@ -90,133 +90,6 @@ void init_stacks(CELL ds_size_, CELL rs_size_) stack_chain = NULL; } -DEFINE_PRIMITIVE(drop) -{ - dpop(); -} - -DEFINE_PRIMITIVE(2drop) -{ - ds -= 2 * CELLS; -} - -DEFINE_PRIMITIVE(3drop) -{ - ds -= 3 * CELLS; -} - -DEFINE_PRIMITIVE(dup) -{ - dpush(dpeek()); -} - -DEFINE_PRIMITIVE(2dup) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - ds += CELLS * 2; - put(ds - CELLS,next); - put(ds,top); -} - -DEFINE_PRIMITIVE(3dup) -{ - CELL c1 = dpeek(); - CELL c2 = get(ds - CELLS); - CELL c3 = get(ds - CELLS * 2); - ds += CELLS * 3; - put (ds,c1); - put (ds - CELLS,c2); - put (ds - CELLS * 2,c3); -} - -DEFINE_PRIMITIVE(rot) -{ - CELL c1 = dpeek(); - CELL c2 = get(ds - CELLS); - CELL c3 = get(ds - CELLS * 2); - put(ds,c3); - put(ds - CELLS,c1); - put(ds - CELLS * 2,c2); -} - -DEFINE_PRIMITIVE(_rot) -{ - CELL c1 = dpeek(); - CELL c2 = get(ds - CELLS); - CELL c3 = get(ds - CELLS * 2); - put(ds,c2); - put(ds - CELLS,c3); - put(ds - CELLS * 2,c1); -} - -DEFINE_PRIMITIVE(dupd) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - put(ds,next); - put(ds - CELLS,next); - dpush(top); -} - -DEFINE_PRIMITIVE(swapd) -{ - CELL top = get(ds - CELLS); - CELL next = get(ds - CELLS * 2); - put(ds - CELLS,next); - put(ds - CELLS * 2,top); -} - -DEFINE_PRIMITIVE(nip) -{ - CELL top = dpop(); - drepl(top); -} - -DEFINE_PRIMITIVE(2nip) -{ - CELL top = dpeek(); - ds -= CELLS * 2; - drepl(top); -} - -DEFINE_PRIMITIVE(tuck) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - put(ds,next); - put(ds - CELLS,top); - dpush(top); -} - -DEFINE_PRIMITIVE(over) -{ - dpush(get(ds - CELLS)); -} - -DEFINE_PRIMITIVE(pick) -{ - dpush(get(ds - CELLS * 2)); -} - -DEFINE_PRIMITIVE(swap) -{ - CELL top = dpeek(); - CELL next = get(ds - CELLS); - put(ds,next); - put(ds - CELLS,top); -} - -DEFINE_PRIMITIVE(to_r) -{ - rpush(dpop()); -} - -DEFINE_PRIMITIVE(from_r) -{ - dpush(rpop()); -} - bool stack_to_array(CELL bottom, CELL top) { F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); @@ -280,13 +153,6 @@ DEFINE_PRIMITIVE(exit) exit(to_fixnum(dpop())); } -DEFINE_PRIMITIVE(eq) -{ - CELL lhs = dpop(); - CELL rhs = dpeek(); - drepl((lhs == rhs) ? T : F); -} - DEFINE_PRIMITIVE(millis) { box_unsigned_8(current_millis()); @@ -297,18 +163,6 @@ DEFINE_PRIMITIVE(sleep) sleep_millis(to_cell(dpop())); } -DEFINE_PRIMITIVE(tag) -{ - drepl(tag_fixnum(TAG(dpeek()))); -} - -DEFINE_PRIMITIVE(slot) -{ - F_FIXNUM slot = untag_fixnum_fast(dpop()); - CELL obj = dpop(); - dpush(get(SLOT(obj,slot))); -} - DEFINE_PRIMITIVE(set_slot) { F_FIXNUM slot = untag_fixnum_fast(dpop()); diff --git a/vm/run.h b/vm/run.h index b54640ec8a..8a03049b93 100755 --- a/vm/run.h +++ b/vm/run.h @@ -245,28 +245,9 @@ DLLEXPORT void save_stacks(void); DLLEXPORT void nest_stacks(void); DLLEXPORT void unnest_stacks(void); void init_stacks(CELL ds_size, CELL rs_size); -DECLARE_PRIMITIVE(drop); -DECLARE_PRIMITIVE(2drop); -DECLARE_PRIMITIVE(3drop); -DECLARE_PRIMITIVE(dup); -DECLARE_PRIMITIVE(2dup); -DECLARE_PRIMITIVE(3dup); -DECLARE_PRIMITIVE(rot); -DECLARE_PRIMITIVE(_rot); -DECLARE_PRIMITIVE(dupd); -DECLARE_PRIMITIVE(swapd); -DECLARE_PRIMITIVE(nip); -DECLARE_PRIMITIVE(2nip); -DECLARE_PRIMITIVE(tuck); -DECLARE_PRIMITIVE(over); -DECLARE_PRIMITIVE(pick); -DECLARE_PRIMITIVE(swap); -DECLARE_PRIMITIVE(to_r); -DECLARE_PRIMITIVE(from_r); + DECLARE_PRIMITIVE(datastack); DECLARE_PRIMITIVE(retainstack); -DECLARE_PRIMITIVE(execute); -DECLARE_PRIMITIVE(call); DECLARE_PRIMITIVE(getenv); DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(exit); @@ -275,11 +256,8 @@ DECLARE_PRIMITIVE(os_envs); DECLARE_PRIMITIVE(set_os_env); DECLARE_PRIMITIVE(unset_os_env); DECLARE_PRIMITIVE(set_os_envs); -DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); DECLARE_PRIMITIVE(sleep); -DECLARE_PRIMITIVE(tag); -DECLARE_PRIMITIVE(slot); DECLARE_PRIMITIVE(set_slot); bool stage2; diff --git a/vm/types.c b/vm/types.c index 3941f13042..59581ecee5 100755 --- a/vm/types.c +++ b/vm/types.c @@ -49,6 +49,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->props = F; word->counter = tag_fixnum(0); word->compiledp = F; + word->subprimitive = F; word->profiling = NULL; word->code = NULL;