From 66ff0243b5d0e8edec0ecb7644c4fe0771176c88 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Dec 2004 07:52:02 +0000 Subject: [PATCH] huge cleanup --- TODO.FACTOR.txt | 8 +- library/bootstrap/boot-stage2.factor | 2 - library/bootstrap/init-stage2.factor | 1 + library/bootstrap/primitives.factor | 43 +++------ library/cli.factor | 14 +-- library/combinators.factor | 31 ------- library/compiler/assembler.factor | 17 ++-- library/cons.factor | 4 + library/errors.factor | 1 + library/generic/generic.factor | 1 + library/httpd/default-responders.factor | 6 -- library/httpd/html.factor | 17 +--- library/httpd/inspect-responder.factor | 40 --------- library/inference/branches.factor | 1 + library/inference/words.factor | 22 ++--- library/io/io-internals.factor | 1 + library/kernel.factor | 11 ++- library/math/complex.factor | 19 ++++ library/math/integer.factor | 14 +++ library/math/ratio.factor | 14 ++- library/namespaces.factor | 42 +++------ library/primitives.factor | 114 +++++++++++------------- library/stack.factor | 5 -- library/strings.factor | 3 + library/test/dataflow.factor | 3 +- library/test/init.factor | 26 ++++++ library/test/lists/cons.factor | 3 + library/test/math/float.factor | 4 - library/test/namespaces.factor | 37 ++------ library/test/vectors.factor | 11 +++ library/threads.factor | 1 + library/tools/debugger.factor | 6 +- library/tools/inspector.factor | 113 ----------------------- library/vectors.factor | 40 +++++++-- library/vocabularies.factor | 9 +- library/words.factor | 26 +++++- native/arithmetic.c | 54 ----------- native/arithmetic.h | 5 -- native/array.c | 21 +++-- native/array.h | 9 +- native/compiler.c | 31 +------ native/compiler.h | 2 - native/complex.c | 64 ++----------- native/complex.h | 8 -- native/cons.c | 9 +- native/cons.h | 3 +- native/factor.h | 2 +- native/float.c | 12 --- native/primitives.c | 35 +++----- native/primitives.h | 2 +- native/ratio.c | 55 ++---------- native/ratio.h | 8 -- native/sbuf.c | 2 +- native/string.c | 12 +-- native/string.h | 2 +- native/types.c | 37 ++++++-- native/types.h | 10 +-- native/unix/io.c | 4 +- native/vector.c | 23 +---- native/vector.h | 3 +- native/word.c | 106 ++++------------------ native/word.h | 16 +--- 62 files changed, 410 insertions(+), 835 deletions(-) delete mode 100644 library/httpd/inspect-responder.factor delete mode 100644 library/tools/inspector.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 1b3f3ad8c4..502bec0e00 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -13,6 +13,8 @@ + compiler: +- slot compilation +- optimize away dispatch - getenv/setenv: if literal arg, compile as a load/store - assembler opcodes dispatch on operand types - save code in image @@ -21,6 +23,7 @@ - make see work with generics - doc comments of generics +- redo traits with generic method map + ffi: @@ -47,10 +50,8 @@ - remove sbufs - cat, reverse-cat primitives - first-class hashtables -- rewrite accessors and mutators in Factor, with slot/set-slot primitive - add a socket timeout - do transfer-word in fixup -- move dispatch getenv setenv to kernel-internals + misc: @@ -62,8 +63,7 @@ - jedit ==> jedit-word, jedit takes a file name - nicer way to combine two paths - ditch object paths -- browser responder for word links in HTTPd; inspect responder for - objects +- browser responder for word links in HTTPd - worddef props - prettyprint: when unparse called due to recursion, write a link diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index a39fbe2e61..daef16f2b7 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -99,7 +99,6 @@ USE: namespaces "/library/io/files.factor" "/library/eval-catch.factor" "/library/tools/listener.factor" - "/library/tools/inspector.factor" "/library/tools/word-tools.factor" "/library/test/test.factor" "/library/io/ansi.factor" @@ -146,7 +145,6 @@ USE: namespaces "/library/httpd/responder.factor" "/library/httpd/httpd.factor" "/library/httpd/file-responder.factor" - "/library/httpd/inspect-responder.factor" "/library/httpd/test-responder.factor" "/library/httpd/quit-responder.factor" "/library/httpd/resource-responder.factor" diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 7a9cf4b3c1..da2f26fe87 100644 --- a/library/bootstrap/init-stage2.factor +++ b/library/bootstrap/init-stage2.factor @@ -42,6 +42,7 @@ USE: stdio USE: presentation USE: words USE: unparser +USE: kernel-internals : cli-args ( -- args ) 10 getenv ; diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 2587b3d03c..9aed3d7c35 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -55,14 +55,9 @@ vocabularies get [ [ "kernel" | "call" ] [ "kernel" | "ifte" ] [ "lists" | "cons" ] - [ "lists" | "car" ] - [ "lists" | "cdr" ] [ "vectors" | "" ] - [ "vectors" | "vector-length" ] - [ "vectors" | "set-vector-length" ] [ "vectors" | "vector-nth" ] [ "vectors" | "set-vector-nth" ] - [ "strings" | "str-length" ] [ "strings" | "str-nth" ] [ "strings" | "str-compare" ] [ "strings" | "str=" ] @@ -85,15 +80,10 @@ vocabularies get [ [ "math" | ">fixnum" ] [ "math" | ">bignum" ] [ "math" | ">float" ] - [ "math" | "numerator" ] - [ "math" | "denominator" ] - [ "math" | "fraction>" ] + [ "math-internals" | "(fraction>)" ] [ "parser" | "str>float" ] [ "unparser" | "(unparse-float)" ] - [ "math" | "float>bits" ] - [ "math" | "real" ] - [ "math" | "imaginary" ] - [ "math" | "rect>" ] + [ "math-internals" | "(rect>)" ] [ "math-internals" | "fixnum=" ] [ "math-internals" | "fixnum+" ] [ "math-internals" | "fixnum-" ] @@ -150,21 +140,9 @@ vocabularies get [ [ "math-internals" | "fsinh" ] [ "math-internals" | "fsqrt" ] [ "words" | "" ] - [ "words" | "word-hashcode" ] - [ "words" | "word-xt" ] - [ "words" | "set-word-xt" ] - [ "words" | "word-primitive" ] - [ "words" | "set-word-primitive" ] - [ "words" | "word-parameter" ] - [ "words" | "set-word-parameter" ] - [ "words" | "word-plist" ] - [ "words" | "set-word-plist" ] + [ "words" | "update-xt" ] [ "profiler" | "call-profiling" ] - [ "profiler" | "call-count" ] - [ "profiler" | "set-call-count" ] [ "profiler" | "allot-profiling" ] - [ "profiler" | "allot-count" ] - [ "profiler" | "set-allot-count" ] [ "words" | "compiled?" ] [ "kernel" | "drop" ] [ "kernel" | "dup" ] @@ -174,8 +152,8 @@ vocabularies get [ [ "kernel" | ">r" ] [ "kernel" | "r>" ] [ "kernel" | "eq?" ] - [ "kernel" | "getenv" ] - [ "kernel" | "setenv" ] + [ "kernel-internals" | "getenv" ] + [ "kernel-internals" | "setenv" ] [ "io-internals" | "open-file" ] [ "files" | "stat" ] [ "files" | "(directory)" ] @@ -214,8 +192,6 @@ vocabularies get [ [ "files" | "cd" ] [ "compiler" | "compiled-offset" ] [ "compiler" | "set-compiled-offset" ] - [ "compiler" | "set-compiled-cell" ] - [ "compiler" | "set-compiled-byte" ] [ "compiler" | "literal-top" ] [ "compiler" | "set-literal-top" ] [ "kernel" | "address" ] @@ -239,6 +215,15 @@ vocabularies get [ [ "kernel-internals" | "memory>string" ] [ "alien" | "local-alien?" ] [ "alien" | "alien-address" ] + [ "lists" | ">cons" ] + [ "vectors" | ">vector" ] + [ "strings" | ">string" ] + [ "words" | ">word" ] + [ "kernel-internals" | "slot" ] + [ "kernel-internals" | "set-slot" ] + [ "kernel-internals" | "integer-slot" ] + [ "kernel-internals" | "set-integer-slot" ] + [ "kernel-internals" | "grow-array" ] ] [ unswons create swap succ [ f define ] keep ] each drop diff --git a/library/cli.factor b/library/cli.factor index 8a61dc9c35..5585e233a3 100644 --- a/library/cli.factor +++ b/library/cli.factor @@ -54,8 +54,12 @@ USE: words ?run-file ] when ; -: cli-var-param ( name value -- ) - swap ":" split set-object-path ; +: set-path ( value list -- ) + unswons over [ nest [ set-path ] bind ] [ nip set ] ifte ; + +: cli-var-param ( name value -- ) swap ":" split set-path ; + +: cli-bool-param ( name -- ) "no-" ?str-head not put ; : cli-param ( param -- ) #! Handle a command-line argument starting with '-' by @@ -64,11 +68,7 @@ USE: words #! #! Arguments containing = are handled differently; they #! set the object path. - "=" split1 [ - cli-var-param - ] [ - "no-" ?str-head not put - ] ifte* ; + "=" split1 [ cli-var-param ] [ cli-bool-param ] ifte* ; : cli-arg ( argument -- argument ) #! Handle a command-line argument. If the argument was diff --git a/library/combinators.factor b/library/combinators.factor index 197fc7c0eb..394b8c981c 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -26,7 +26,6 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: kernel -USE: lists : slip ( quot x -- x ) >r call r> ; inline @@ -51,36 +50,6 @@ USE: lists #! Apply code to input. swap dup >r call r> swap ; inline -IN: lists DEFER: uncons IN: kernel -: cond ( x list -- ) - #! The list is of this form: - #! - #! [ [ condition 1 ] [ code 1 ] - #! [ condition 2 ] [ code 2 ] - #! ... ] - #! - #! Each condition is evaluated in turn. If it returns true, - #! the code is evaluated. If it returns false, the next - #! condition is checked. - #! - #! Before evaluating each condition, the top of the stack is - #! duplicated. After the last condition is evaluated, the - #! top of the stack is popped. - #! - #! So each condition and code block must have stack effect: - #! ( X -- ) - #! - #! This combinator will not compile. - dup [ - uncons >r over >r call r> r> rot [ - car call - ] [ - cdr cond - ] ifte - ] [ - 2drop - ] ifte ; - : ifte* ( cond true false -- ) #! If the condition is not f, execute the 'true' quotation, #! with the condition on the stack. Otherwise, pop the diff --git a/library/compiler/assembler.factor b/library/compiler/assembler.factor index c4384fd11e..4cc3347c1f 100644 --- a/library/compiler/assembler.factor +++ b/library/compiler/assembler.factor @@ -26,17 +26,24 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: compiler +USE: alien USE: math USE: kernel -: cell 4 ; -: literal-table 1024 cell * ; +: cell 4 ; inline +: literal-table 1024 cell * ; inline : init-assembler ( -- ) compiled-offset literal-table + set-compiled-offset ; +: set-compiled-byte ( n addr -- ) + 0 set-alien-1 ; inline + +: set-compiled-cell ( n addr -- ) + 0 set-alien-cell ; inline + : compile-aligned ( n -- ) - compiled-offset swap align set-compiled-offset ; + compiled-offset swap align set-compiled-offset ; inline : intern-literal ( obj -- lit# ) address @@ -45,8 +52,8 @@ USE: kernel : compile-byte ( n -- ) compiled-offset set-compiled-byte - compiled-offset 1 + set-compiled-offset ; + compiled-offset 1 + set-compiled-offset ; inline : compile-cell ( n -- ) compiled-offset set-compiled-cell - compiled-offset cell + set-compiled-offset ; + compiled-offset cell + set-compiled-offset ; inline diff --git a/library/cons.factor b/library/cons.factor index 165a8c0316..689791bc66 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -28,6 +28,7 @@ IN: lists USE: generic USE: kernel +USE: kernel-internals ! This file contains vital list-related words that everything ! else depends on, and is loaded early in bootstrap. @@ -35,6 +36,9 @@ USE: kernel BUILTIN: cons 2 +: car ( [ car | cdr ] -- car ) >cons 0 slot ; inline +: cdr ( [ car | cdr ] -- cdr ) >cons 1 slot ; inline + : swons ( cdr car -- [ car | cdr ] ) #! Push a new cons cell. If the cdr is f or a proper list, #! has the effect of prepending the car to the cdr. diff --git a/library/errors.factor b/library/errors.factor index 53eded4680..ad0109c116 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -30,6 +30,7 @@ DEFER: callcc1 IN: errors USE: kernel +USE: kernel-internals USE: lists USE: math USE: namespaces diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 6db9483543..affa2bb049 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -29,6 +29,7 @@ IN: generic USE: errors USE: hashtables USE: kernel +USE: kernel-internals USE: lists USE: namespaces USE: parser diff --git a/library/httpd/default-responders.factor b/library/httpd/default-responders.factor index 5ccf6217eb..39cc7c89d4 100644 --- a/library/httpd/default-responders.factor +++ b/library/httpd/default-responders.factor @@ -51,12 +51,6 @@ global [ "httpd-responders" set ] bind [ test-responder ] "get" set ] extend add-responder - [ - "inspect" "responder" set - [ inspect-responder ] "get" set - "global" "default-argument" set -] extend add-responder - [ "quit" "responder" set [ quit-responder ] "get" set diff --git a/library/httpd/html.factor b/library/httpd/html.factor index d73e3d60c4..00f3f3fdad 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -110,17 +110,6 @@ USE: generic call ] ifte* ; -: object-link-href ( path -- href ) - #! Perhaps this should not be hard-coded. - "/responder/inspect/" swap cat2 ; - -: object-link-tag ( style quot -- ) - over "object-link" swap assoc [ - call - ] [ - call - ] ifte* ; - : icon-tag ( string style quot -- ) over "icon" swap assoc dup [ @@ -137,10 +126,8 @@ M: html-stream fwrite-attr ( str style stream -- ) [ [ [ - [ - [ drop chars>entities write ] span-tag - ] file-link-tag - ] object-link-tag + [ drop chars>entities write ] span-tag + ] file-link-tag ] icon-tag ] bind ; diff --git a/library/httpd/inspect-responder.factor b/library/httpd/inspect-responder.factor deleted file mode 100644 index 3b626cbff5..0000000000 --- a/library/httpd/inspect-responder.factor +++ /dev/null @@ -1,40 +0,0 @@ -! :folding=indent:collapseFolds=0: - -! $Id$ -! -! Copyright (C) 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: inspect-responder -USE: html -USE: inspector -USE: namespaces -USE: kernel - -USE: httpd -USE: httpd-responder - -: inspect-responder ( argument -- ) - serving-html dup [ - describe-path - ] simple-html-document ; diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 56b16f0002..c47b5405b6 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -194,5 +194,6 @@ USE: hashtables pop-d drop ( n ) infer-branches ; +USE: kernel-internals \ dispatch [ infer-dispatch ] "infer" set-word-property \ dispatch [ 2 | 0 ] "infer-effect" set-word-property diff --git a/library/inference/words.factor b/library/inference/words.factor index b35838b65a..970efd7f9e 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -136,7 +136,9 @@ USE: parser ] when* ] catch ; -: apply-compound ( word -- ) +GENERIC: (apply-word) + +M: compound (apply-word) ( word -- ) #! Infer a compound word's stack effect. dup "inline" word-property [ inline-compound drop @@ -144,6 +146,9 @@ USE: parser infer-compound ] ifte ; +M: symbol (apply-word) ( word -- ) + apply-literal ; + : current-word ( -- word ) #! Push word we're currently inferring effect of. recursive-state get car car ; @@ -175,9 +180,6 @@ USE: parser 2drop no-base-case ] ifte ; -: no-effect? ( word -- ? ) - "no-effect" word-property ; - : apply-word ( word -- ) #! Apply the word's stack effect to the inferencer state. dup recursive-state get assoc dup [ @@ -186,13 +188,11 @@ USE: parser drop dup "infer-effect" word-property dup [ apply-effect ] [ - drop - [ - [ no-effect? ] [ no-effect ] - [ compound? ] [ apply-compound ] - [ symbol? ] [ apply-literal ] - [ drop t ] [ no-effect ] - ] cond + drop dup "no-effect" word-property [ + no-effect + ] [ + (apply-word) + ] ifte ] ifte ] ifte ; diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor index 0496ac2793..b0e55c2f83 100644 --- a/library/io/io-internals.factor +++ b/library/io/io-internals.factor @@ -28,6 +28,7 @@ IN: io-internals USE: generic USE: kernel +USE: kernel-internals USE: namespaces USE: strings USE: threads diff --git a/library/kernel.factor b/library/kernel.factor index 00620bcf3c..8785ff03aa 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -25,10 +25,16 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: kernel +IN: kernel-internals USE: generic +USE: kernel USE: vectors +: dispatch ( n vtable -- ) + vector-nth call ; + +IN: kernel + GENERIC: hashcode ( obj -- n ) M: object hashcode drop 0 ; @@ -43,9 +49,6 @@ M: object = eq? ; #! Returns one of "unix" or "win32". 11 getenv ; -: dispatch ( n vtable -- ) - vector-nth call ; - : set-boot ( quot -- ) #! Set the boot quotation. 8 setenv ; diff --git a/library/math/complex.factor b/library/math/complex.factor index fe5ab31fad..2e606f8825 100644 --- a/library/math/complex.factor +++ b/library/math/complex.factor @@ -25,12 +25,31 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +IN: errors +DEFER: throw + IN: math USE: generic USE: kernel +USE: kernel-internals USE: math USE: math-internals +GENERIC: real ( #{ re im } -- re ) +M: real real ; +M: complex real 0 slot ; + +GENERIC: imaginary ( #{ re im } -- im ) +M: real imaginary drop 0 ; +M: complex imaginary 1 slot ; + +: rect> ( xr xi -- x ) + over real? over real? and [ + dup 0 = [ drop ] [ (rect>) ] ifte + ] [ + "Complex number must have real components" throw drop + ] ifte ; inline + : >rect ( x -- xr xi ) dup real swap imaginary ; inline : conjugate ( z -- z* ) diff --git a/library/math/integer.factor b/library/math/integer.factor index 312a12ed5b..182388351e 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -25,6 +25,9 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +IN: errors +DEFER: throw + IN: math-internals USE: generic USE: kernel @@ -34,6 +37,17 @@ USE: math dup 0 < [ swap neg swap neg ] when 2dup gcd tuck /i >r /i r> ; inline +: fraction> ( a b -- a/b ) + dup 0 = [ + "Division by zero" throw drop + ] [ + dup 1 = [ + drop + ] [ + (fraction>) + ] ifte + ] ifte ; inline + : integer/ ( x y -- x/y ) reduce fraction> ; inline diff --git a/library/math/ratio.factor b/library/math/ratio.factor index 7ac630d47f..2ab1ebd224 100644 --- a/library/math/ratio.factor +++ b/library/math/ratio.factor @@ -25,10 +25,22 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: math-internals +IN: math USE: generic USE: kernel +USE: kernel-internals USE: math +USE: math-internals + +GENERIC: numerator ( a/b -- a ) +M: integer numerator ; +M: ratio numerator 0 slot ; + +GENERIC: denominator ( a/b -- b ) +M: integer denominator drop 1 ; +M: ratio denominator 1 slot ; + +IN: math-internals : 2>fraction ( a/b c/d -- a c b d ) [ swap numerator swap numerator ] 2keep diff --git a/library/namespaces.factor b/library/namespaces.factor index 79160b77b5..2d669d5d95 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -28,9 +28,8 @@ IN: namespaces USE: hashtables USE: kernel +USE: kernel-internals USE: lists -USE: strings -USE: vectors ! Other languages have classes, objects, variables, etc. ! Factor has similar concepts. @@ -72,11 +71,9 @@ USE: vectors : init-namespaces ( -- ) global >n ; -: namespace-buckets 23 ; - : ( -- n ) #! Create a new namespace. - namespace-buckets ; + 23 ; : (get) ( var ns -- value ) #! Internal word for searching the namestack. @@ -98,6 +95,15 @@ USE: vectors : set ( value variable -- ) namespace set-hash ; : put ( variable value -- ) swap set ; +: nest ( variable -- hash ) + #! If the variable is set in the current namespace, return + #! its value, otherwise set its value to a new namespace. + dup namespace hash dup [ + nip + ] [ + drop >r dup r> set + ] ifte ; + : change ( var quot -- ) #! Execute the quotation with the variable value on the #! stack. The set the variable to the return value of the @@ -121,31 +127,5 @@ USE: vectors #! ] extend ; over >r bind r> ; inline -: traverse-path ( name object -- object ) - dup hashtable? [ hash ] [ 2drop f ] ifte ; - -: (object-path) ( object list -- object ) - [ uncons >r swap traverse-path r> (object-path) ] when* ; - -: object-path ( list -- object ) - #! An object path is a list of strings. Each string is a - #! variable name in the object namespace at that level. - #! Returns f if any of the objects are not set. - namespace swap (object-path) ; - -: (set-object-path) ( name -- namespace ) - dup namespace hash dup [ - nip - ] [ - drop tuck put - ] ifte ; - -: set-object-path ( value list -- ) - unswons over [ - (set-object-path) [ set-object-path ] bind - ] [ - nip set - ] ifte ; - : on ( var -- ) t put ; : off ( var -- ) f put ; diff --git a/library/primitives.factor b/library/primitives.factor index bb0d2fb105..867fdcaf8f 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -27,6 +27,7 @@ IN: alien DEFER: alien +DEFER: dll USE: alien USE: compiler @@ -52,14 +53,9 @@ USE: words [ call " quot -- " [ [ general-list ] [ ] ] ] [ ifte " cond true false -- " [ [ object general-list general-list ] [ ] ] ] [ cons " car cdr -- [ car | cdr ] " [ [ object object ] [ cons ] ] ] - [ car " [ car | cdr ] -- car " [ [ cons ] [ object ] ] ] - [ cdr " [ car | cdr ] -- cdr " [ [ cons ] [ object ] ] ] [ " capacity -- vector" [ [ integer ] [ vector ] ] ] - [ vector-length " vector -- n " [ [ vector ] [ integer ] ] ] - [ set-vector-length " n vector -- " [ [ integer vector ] [ ] ] ] [ vector-nth " n vector -- obj " [ [ integer vector ] [ object ] ] ] [ set-vector-nth " obj n vector -- " [ [ object integer vector ] [ ] ] ] - [ str-length " str -- n " [ [ string ] [ integer ] ] ] [ str-nth " n str -- ch " [ [ integer string ] [ integer ] ] ] [ str-compare " str str -- -1/0/1 " [ [ string string ] [ integer ] ] ] [ str= " str str -- ? " [ [ string string ] [ boolean ] ] ] @@ -82,15 +78,10 @@ USE: words [ >fixnum " n -- fixnum " [ [ number ] [ fixnum ] ] ] [ >bignum " n -- bignum " [ [ number ] [ bignum ] ] ] [ >float " n -- float " [ [ number ] [ float ] ] ] - [ numerator " a/b -- a " [ [ rational ] [ integer ] ] ] - [ denominator " a/b -- b " [ [ rational ] [ integer ] ] ] - [ fraction> " a b -- a/b " [ [ integer integer ] [ rational ] ] ] + [ (fraction>) " a b -- a/b " [ [ integer integer ] [ rational ] ] ] [ str>float " str -- float " [ [ string ] [ float ] ] ] [ (unparse-float) " float -- str " [ [ float ] [ string ] ] ] - [ float>bits " float -- n " [ [ float ] [ integer ] ] ] - [ real " #{ re im } -- re " [ [ number ] [ real ] ] ] - [ imaginary " #{ re im } -- im " [ [ number ] [ real ] ] ] - [ rect> " re im -- #{ re im } " [ [ real real ] [ number ] ] ] + [ (rect>) " re im -- #{ re im } " [ [ real real ] [ number ] ] ] [ fixnum= " x y -- ? " [ [ fixnum fixnum ] [ boolean ] ] ] [ fixnum+ " x y -- x+y " [ [ fixnum fixnum ] [ integer ] ] ] [ fixnum- " x y -- x-y " [ [ fixnum fixnum ] [ integer ] ] ] @@ -146,16 +137,8 @@ USE: words [ fsin " x -- y " [ [ real ] [ float ] ] ] [ fsinh " x -- y " [ [ real ] [ float ] ] ] [ fsqrt " x -- y " [ [ real ] [ float ] ] ] - [ " prim param plist -- word " [ [ integer object general-list ] [ word ] ] ] - [ word-hashcode " word -- n " [ [ word ] [ integer ] ] ] - [ word-xt " word -- xt " [ [ word ] [ integer ] ] ] - [ set-word-xt " xt word -- " [ [ integer word ] [ ] ] ] - [ word-primitive " word -- n " [ [ word ] [ integer ] ] ] - [ set-word-primitive " n word -- " [ [ integer word ] [ ] ] ] - [ word-parameter " word -- obj " [ [ word ] [ object ] ] ] - [ set-word-parameter " obj word -- " [ [ object word ] [ ] ] ] - [ word-plist " word -- alist" [ [ word ] [ general-list ] ] ] - [ set-word-plist " alist word -- " [ [ general-list word ] [ ] ] ] + [ " -- word " [ [ ] [ word ] ] ] + [ update-xt " word -- " [ [ word ] [ ] ] ] [ drop " x -- " [ [ object ] [ ] ] ] [ dup " x -- x x " [ [ object ] [ object object ] ] ] [ swap " x y -- y x " [ [ object object ] [ object object ] ] ] @@ -166,19 +149,19 @@ USE: words [ eq? " x y -- ? " [ [ object object ] [ boolean ] ] ] [ getenv " n -- obj " [ [ fixnum ] [ object ] ] ] [ setenv " obj n -- " [ [ object fixnum ] [ ] ] ] - [ open-file " path r w -- port " [ 3 | 1 ] ] - [ stat " path -- [ dir? perm size mtime ] " [ 1 | 1 ] ] - [ (directory) " path -- list " [ 1 | 1 ] ] - [ garbage-collection " -- " [ 0 | 0 ] ] - [ save-image " path -- " [ 1 | 0 ] ] + [ open-file " path r w -- port " [ [ string object object ] [ port ] ] ] + [ stat " path -- [ dir? perm size mtime ] " [ [ string ] [ cons ] ] ] + [ (directory) " path -- list " [ [ string ] [ general-list ] ] ] + [ garbage-collection " -- " [ [ ] [ ] ] ] + [ save-image " path -- " [ [ string ] [ ] ] ] [ datastack " -- ds " f ] [ callstack " -- cs " f ] [ set-datastack " ds -- " f ] [ set-callstack " cs -- " f ] - [ exit* " n -- " [ 1 | 0 ] ] - [ client-socket " host port -- in out " [ 2 | 2 ] ] - [ server-socket " port -- server " [ 1 | 1 ] ] - [ close-port " port -- " [ 1 | 0 ] ] + [ exit* " n -- " [ [ integer ] [ ] ] ] + [ client-socket " host port -- in out " [ [ string integer ] [ port port ] ] ] + [ server-socket " port -- server " [ [ integer ] [ port ] ] ] + [ close-port " port -- " [ [ port ] ] ] [ add-accept-io-task " server callback -- " [ 2 | 0 ] ] [ accept-fd " server -- host port in out " [ 1 | 4 ] ] [ can-read-line? " port -- ? " [ 1 | 1 ] ] @@ -195,45 +178,48 @@ USE: words [ next-io-task " -- callback " [ 0 | 1 ] ] [ room " -- free total free total " [ 0 | 4 ] ] [ os-env " str -- str " [ 1 | 1 ] ] - [ millis " -- n " [ 0 | 1 ] ] - [ init-random " -- " [ 0 | 0 ] ] - [ (random-int) " -- n " [ 0 | 1 ] ] - [ type " obj -- n " [ 1 | 1 ] ] - [ call-profiling " depth -- " [ 1 | 0 ] ] - [ call-count " word -- n " [ 1 | 1 ] ] - [ set-call-count " n word -- " [ 2 | 0 ] ] - [ allot-profiling " depth -- " [ 1 | 0 ] ] - [ allot-count " word -- n " [ 1 | 1 ] ] - [ set-allot-count " n word -- n " [ 2 | 1 ] ] - [ cwd " -- dir " [ 0 | 1 ] ] - [ cd " dir -- " [ 1 | 0 ] ] - [ compiled-offset " -- ptr " [ 0 | 1 ] ] - [ set-compiled-offset " ptr -- " [ 1 | 0 ] ] - [ set-compiled-cell " n ptr -- " [ 2 | 0 ] ] - [ set-compiled-byte " n ptr -- " [ 2 | 0 ] ] - [ literal-top " -- ptr " [ 0 | 1 ] ] - [ set-literal-top " ptr -- " [ 1 | 0 ] ] - [ address " obj -- ptr " [ 1 | 1 ] ] - [ dlopen " path -- dll " [ 1 | 1 ] ] - [ dlsym " name dll -- ptr " [ 2 | 1 ] ] - [ dlsym-self " name -- ptr " [ 1 | 1 ] ] - [ dlclose " dll -- " [ 1 | 0 ] ] - [ " ptr -- alien " [ 1 | 1 ] ] - [ " len -- alien " [ 1 | 1 ] ] - [ alien-cell " alien off -- n " [ 2 | 1 ] ] - [ set-alien-cell " n alien off -- " [ 3 | 0 ] ] - [ alien-4 " alien off -- n " [ 2 | 1 ] ] - [ set-alien-4 " n alien off -- " [ 3 | 0 ] ] - [ alien-2 " alien off -- n " [ 2 | 1 ] ] - [ set-alien-2 " n alien off -- " [ 3 | 0 ] ] - [ alien-1 " alien off -- n " [ 2 | 1 ] ] - [ set-alien-1 " n alien off -- " [ 3 | 0 ] ] + [ millis " -- n " [ [ ] [ integer ] ] ] + [ init-random " -- " [ [ ] [ ] ] ] + [ (random-int) " -- n " [ [ ] [ integer ] ] ] + [ type " obj -- n " [ [ object ] [ fixnum ] ] ] + [ call-profiling " depth -- " [ [ integer ] [ ] ] ] + [ allot-profiling " depth -- " [ [ integer ] [ ] ] ] + [ cwd " -- dir " [ [ ] [ string ] ] ] + [ cd " dir -- " [ [ string ] [ ] ] ] + [ compiled-offset " -- ptr " [ [ ] [ integer ] ] ] + [ set-compiled-offset " ptr -- " [ [ integer ] [ ] ] ] + [ literal-top " -- ptr " [ [ ] [ integer ] ] ] + [ set-literal-top " ptr -- " [ [ integer ] [ ] ] ] + [ address " obj -- ptr " [ [ object ] [ integer ] ] ] + [ dlopen " path -- dll " [ [ string ] [ dll ] ] ] + [ dlsym " name dll -- ptr " [ [ string dll ] [ integer ] ] ] + [ dlsym-self " name -- ptr " [ [ string ] [ integer ] ] ] + [ dlclose " dll -- " [ [ dll ] [ ] ] ] + [ " ptr -- alien " [ [ integer ] [ alien ] ] ] + [ " len -- alien " [ [ integer ] [ alien ] ] ] + [ alien-cell " alien off -- n " [ [ alien integer ] [ integer ] ] ] + [ set-alien-cell " n alien off -- " [ [ integer alien integer ] [ ] ] ] + [ alien-4 " alien off -- n " [ [ alien integer ] [ integer ] ] ] + [ set-alien-4 " n alien off -- " [ [ integer alien integer ] [ ] ] ] + [ alien-2 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ] + [ set-alien-2 " n alien off -- " [ [ integer alien integer ] [ ] ] ] + [ alien-1 " alien off -- n " [ [ alien integer ] [ fixnum ] ] ] + [ set-alien-1 " n alien off -- " [ [ integer alien integer ] [ ] ] ] [ heap-stats " -- instances bytes " [ [ ] [ general-list ] ] ] [ throw " error -- " [ [ object ] [ ] ] ] [ string>memory " str address -- " [ [ string integer ] [ ] ] ] [ memory>string " address length -- str " [ [ integer integer ] [ string ] ] ] [ local-alien? " alien -- ? " [ [ alien ] [ object ] ] ] [ alien-address " alien -- address " [ [ alien ] [ integer ] ] ] + [ >cons " cons -- cons " [ [ cons ] [ cons ] ] ] + [ >vector " vector -- vector " [ [ vector ] [ vector ] ] ] + [ >string " string -- string " [ [ string ] [ string ] ] ] + [ >word " word -- word " [ [ word ] [ word ] ] ] + [ slot " obj n -- obj " [ [ object fixnum ] [ object ] ] ] + [ set-slot " obj obj n -- " [ [ object object fixnum ] [ ] ] ] + [ integer-slot " obj n -- n " [ [ object fixnum ] [ integer ] ] ] + [ set-integer-slot " n obj n -- " [ [ integer object fixnum ] [ ] ] ] + [ grow-array " n array -- array " [ [ integer array ] [ integer ] ] ] ] [ uncons dupd uncons car ( word word stack-effect infer-effect ) >r "stack-effect" set-word-property r> diff --git a/library/stack.factor b/library/stack.factor index 1ab96642ab..19dfc2d7d4 100644 --- a/library/stack.factor +++ b/library/stack.factor @@ -26,7 +26,6 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: kernel -USE: vectors : 2drop ( x x -- ) drop drop ; inline : 3drop ( x x x -- ) drop drop drop ; inline @@ -44,7 +43,3 @@ USE: vectors #! this from a word definition will clobber any values left #! on the data stack by the caller. { } set-datastack ; - -: depth ( -- n ) - #! Push the number of elements on the datastack. - datastack vector-length ; diff --git a/library/strings.factor b/library/strings.factor index b93b9c65ed..d8d9efbc8d 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -28,6 +28,7 @@ IN: strings USE: generic USE: kernel +USE: kernel-internals USE: lists USE: math @@ -36,6 +37,8 @@ BUILTIN: string 12 M: string hashcode str-hashcode ; M: string = str= ; +: str-length ( str -- len ) >string 1 integer-slot ; inline + BUILTIN: sbuf 13 M: sbuf hashcode sbuf-hashcode ; M: sbuf = sbuf= ; diff --git a/library/test/dataflow.factor b/library/test/dataflow.factor index 2c31aae441..ec395c7616 100644 --- a/library/test/dataflow.factor +++ b/library/test/dataflow.factor @@ -10,6 +10,7 @@ USE: namespaces USE: prettyprint USE: words USE: kernel +USE: kernel-internals USE: generic : dataflow-contains-op? ( object list -- ? ) @@ -36,7 +37,7 @@ USE: generic car car ; inline [ t ] [ - \ car [ inline-test ] dataflow dataflow-contains-param? >boolean + \ slot [ inline-test ] dataflow dataflow-contains-param? >boolean ] unit-test [ t ] [ diff --git a/library/test/init.factor b/library/test/init.factor index 9df05858d6..9886cc084a 100644 --- a/library/test/init.factor +++ b/library/test/init.factor @@ -2,6 +2,9 @@ IN: scratchpad USE: command-line USE: namespaces USE: test +USE: kernel +USE: hashtables +USE: lists [ [ f ] [ "-no-user-init" cli-arg ] unit-test @@ -12,3 +15,26 @@ USE: test [ "sdl.factor" ] [ "sdl.factor" cli-arg ] unit-test ] with-scope + +: traverse-path ( name object -- object ) + dup hashtable? [ hash ] [ 2drop f ] ifte ; + +: (object-path) ( object list -- object ) + [ uncons >r swap traverse-path r> (object-path) ] when* ; + +: object-path ( list -- object ) + #! An object path is a list of strings. Each string is a + #! variable name in the object namespace at that level. + #! Returns f if any of the objects are not set. + namespace swap (object-path) ; + +[ + 5 [ "test" "object" "path" ] set-path + [ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test + + 7 [ "test" "object" "pathe" ] set-path + [ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test + + 9 [ "teste" "object" "pathe" ] set-path + [ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test +] with-scope diff --git a/library/test/lists/cons.factor b/library/test/lists/cons.factor index 9d82af3315..34c04040e4 100644 --- a/library/test/lists/cons.factor +++ b/library/test/lists/cons.factor @@ -2,6 +2,9 @@ IN: scratchpad USE: lists USE: test +[ 5 car ] unit-test-fails +[ "Hello world" cdr ] unit-test-fails + [ f ] [ f cons? ] unit-test [ f ] [ t cons? ] unit-test [ t ] [ [ t | f ] cons? ] unit-test diff --git a/library/test/math/float.factor b/library/test/math/float.factor index 756451be33..7aa69d0107 100644 --- a/library/test/math/float.factor +++ b/library/test/math/float.factor @@ -29,7 +29,3 @@ USE: test [ t ] [ pi 3 > ] unit-test [ f ] [ e 2 <= ] unit-test - -[ 4607182418800017408 ] [ 1.0 float>bits ] unit-test -[ 4614256656552045848 ] [ pi float>bits ] unit-test -[ 4613303445314885481 ] [ e float>bits ] unit-test diff --git a/library/test/namespaces.factor b/library/test/namespaces.factor index 08926e7be7..0cb8d54e3f 100644 --- a/library/test/namespaces.factor +++ b/library/test/namespaces.factor @@ -11,40 +11,15 @@ USE: words [ t ] [ test-namespace ] unit-test -! Object paths should not resolve further up in the namestack. - - "test-namespace" set -[ f ] -[ [ "test-namespace" "test-namespace" ] object-path ] -unit-test - -[ f ] -[ [ "alalal" "boobobo" "bah" ] object-path ] -unit-test - -[ t ] -[ namespace [ ] object-path = ] -unit-test - -[ t ] [ - \ test-word - global [ [ vocabularies "test" "test-word" ] object-path ] bind - = -] unit-test + "nested" off + + "nested" nest [ 5 "x" set ] bind + [ 5 ] [ "nested" nest [ "x" get ] bind ] unit-test + +] with-scope 10 "some-global" set [ f ] [ [ f "some-global" set "some-global" get ] bind ] unit-test - -[ - 5 [ "test" "object" "path" ] set-object-path - [ 5 ] [ [ "test" "object" "path" ] object-path ] unit-test - - 7 [ "test" "object" "pathe" ] set-object-path - [ 7 ] [ [ "test" "object" "pathe" ] object-path ] unit-test - - 9 [ "teste" "object" "pathe" ] set-object-path - [ 9 ] [ [ "teste" "object" "pathe" ] object-path ] unit-test -] with-scope diff --git a/library/test/vectors.factor b/library/test/vectors.factor index 618c40366d..5c4c2be505 100644 --- a/library/test/vectors.factor +++ b/library/test/vectors.factor @@ -6,9 +6,20 @@ USE: test USE: vectors USE: strings +[ [ t f t ] vector-length ] unit-test-fails +[ 3 ] [ { t f t } vector-length ] unit-test + [ 3 { } vector-nth ] unit-test-fails [ 3 #{ 1 2 } vector-nth ] unit-test-fails +[ "hey" [ 1 2 ] set-vector-length ] unit-test-fails +[ "hey" { 1 2 } set-vector-length ] unit-test-fails + +[ 3 ] [ 3 0 [ set-vector-length ] keep vector-length ] unit-test +[ "yo" ] [ + "yo" 4 1 [ set-vector-nth ] keep 4 swap vector-nth +] unit-test + [ 5 list>vector ] unit-test-fails [ { } ] [ [ ] list>vector ] unit-test [ { 1 2 } ] [ [ 1 2 ] list>vector ] unit-test diff --git a/library/threads.factor b/library/threads.factor index cdf9239fd9..90f4a0e99f 100644 --- a/library/threads.factor +++ b/library/threads.factor @@ -28,6 +28,7 @@ IN: threads USE: io-internals USE: kernel +USE: kernel-internals USE: lists ! Core of the multitasker. Used by io-internals.factor and diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index 441e753efe..c7678d6f27 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -27,6 +27,7 @@ IN: errors USE: kernel +USE: kernel-internals USE: lists USE: namespaces USE: prettyprint @@ -63,10 +64,7 @@ USE: generic #! reporting. dup [ [ 100 | "fixnum/bignum" ] - [ 101 | "fixnum/bignum/ratio" ] - [ 102 | "fixnum/bignum/ratio/float" ] - [ 103 | "fixnum/bignum/ratio/float/complex" ] - [ 104 | "fixnum/string" ] + [ 104 | "fixnum/bignum/string" ] ] assoc dup [ nip ] [ diff --git a/library/tools/inspector.factor b/library/tools/inspector.factor deleted file mode 100644 index 6cfbf989d1..0000000000 --- a/library/tools/inspector.factor +++ /dev/null @@ -1,113 +0,0 @@ -! :folding=indent:collapseFolds=1: - -! $Id$ -! -! Copyright (C) 2003, 2004 Slava Pestov. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -IN: inspector -USE: kernel -USE: hashtables -USE: lists -USE: namespaces -USE: stdio -USE: strings -USE: presentation -USE: words -USE: prettyprint -USE: unparser -USE: vectors -USE: math - -: relative>absolute-object-path ( string -- string ) - "object-path" get [ "'" rot cat3 ] when* ; - -: vars. ( -- ) - #! Print a list of defined variables. - namespace hash-keys [.] ; - -: object-actions ( -- alist ) - [ - [ "Describe" | "describe-path" ] - [ "Push" | "lookup" ] - ] ; - -: link-style ( path -- style ) - relative>absolute-object-path - dup "object-link" swons swap - object-actions "actions" swons - t "underline" swons - 3list - default-style append ; - -: pad-string ( len str -- str ) - str-length - " " fill ; - -: var-name. ( max name -- ) - tuck unparse pad-string write dup link-style - swap unparse swap write-attr ; - -: value. ( max name value -- ) - >r var-name. ": " write r> . ; - -: max-str-length ( list -- len ) - #! Returns the length of the longest string in the given - #! list. - 0 swap [ str-length max ] each ; - -: name-padding ( alist -- col ) - [ car unparse ] map max-str-length ; - -: describe-assoc ( alist -- ) - dup name-padding swap - [ dupd uncons value. ] each drop ; - -: alist-sort ( list -- list ) - [ swap car unparse swap car unparse str-lexi> ] sort ; - -: describe-hashtable ( hashtables -- ) - hash>alist alist-sort describe-assoc ; - -: describe ( obj -- ) - [ - [ word? ] - [ see ] - - [ string? ] - [ print ] - - [ assoc? ] - [ describe-assoc ] - - [ hashtable? ] - [ describe-hashtable ] - - [ drop t ] - [ prettyprint ] - ] cond ; - -: lookup ( str -- object ) - global [ "'" split object-path ] bind ; - -: describe-path ( string -- ) - [ dup "object-path" set lookup describe ] with-scope ; diff --git a/library/vectors.factor b/library/vectors.factor index ef43e04af3..7919f0dfa9 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -25,18 +25,41 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: kernel-internals USE: generic - -BUILTIN: array 8 - -IN: vectors USE: kernel USE: lists USE: math +IN: errors +DEFER: throw + +IN: kernel-internals + +BUILTIN: array 8 + +! UNSAFE! +: array-capacity ( array -- n ) 1 integer-slot ; inline +: vector-array ( vec -- array ) 2 slot ; inline +: set-vector-array ( array vec -- ) 2 set-slot ; inline + +: grow-vector-array ( len vec -- ) + [ vector-array grow-array ] keep set-vector-array ; inline + +: (set-vector-length) ( len vec -- ) 1 set-integer-slot ; inline + +IN: vectors + BUILTIN: vector 11 +: vector-length ( vec -- len ) >vector 1 integer-slot ; inline + +: set-vector-length ( len vec -- ) + >vector over 0 < [ + "Vector length must be positive" throw 2drop + ] [ + 2dup (set-vector-length) grow-vector-array + ] ifte ; + : empty-vector ( len -- vec ) #! Creates a vector with 'len' elements set to f. Unlike #! , which gives an empty vector with a certain @@ -162,3 +185,10 @@ M: vector hashcode ( vec -- n ) #! vector. For example, if n=1, this returns a vector of #! one element. [ vector-length swap - ] keep vector-tail ; + +! Find a better place for this +IN: kernel + +: depth ( -- n ) + #! Push the number of elements on the datastack. + datastack vector-length ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index e4d9301bee..85f78d699e 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -77,14 +77,14 @@ USE: strings : (create) ( name vocab -- word ) #! Create an undefined word without adding to a vocabulary. - 0 f rot ; + [ set-word-plist ] keep ; : reveal ( word -- ) #! Add a new word to its vocabulary. vocabularies get [ - dup word-vocabulary - over word-name - 2list set-object-path + dup word-vocabulary nest [ + dup word-name set + ] bind ] bind ; : create ( name vocab -- word ) @@ -115,7 +115,6 @@ USE: strings "inference" "inferior" "interpreter" - "inspector" "jedit" "kernel" "listener" diff --git a/library/words.factor b/library/words.factor index 9043460105..3ff1628f16 100644 --- a/library/words.factor +++ b/library/words.factor @@ -29,6 +29,7 @@ IN: words USE: generic USE: hashtables USE: kernel +USE: kernel-internals USE: lists USE: math USE: namespaces @@ -36,17 +37,36 @@ USE: strings BUILTIN: word 1 -M: word hashcode word-hashcode ; +M: word hashcode 1 integer-slot ; + +: word-xt ( w -- xt ) >word 2 integer-slot ; inline +: set-word-xt ( xt w -- ) >word 2 set-integer-slot ; inline + +: word-primitive ( w -- n ) >word 3 integer-slot ; inline +: set-word-primitive ( n w -- ) + >word [ 3 set-integer-slot ] keep update-xt ; inline + +: word-parameter ( w -- obj ) >word 4 slot ; inline +: set-word-parameter ( obj w -- ) >word 4 set-slot ; inline + +: word-plist ( w -- obj ) >word 5 slot ; inline +: set-word-plist ( obj w -- ) >word 5 set-slot ; inline + +: call-count ( w -- n ) >word 6 integer-slot ; inline +: set-call-count ( n w -- ) >word 6 set-integer-slot ; inline + +: allot-count ( w -- n ) >word 7 integer-slot ; inline +: set-allot-count ( n w -- ) >word 7 set-integer-slot ; inline SYMBOL: vocabularies : word-property ( word pname -- pvalue ) - swap word-plist assoc ; + swap word-plist assoc ; inline : set-word-property ( word pvalue pname -- ) pick word-plist pick [ set-assoc ] [ remove-assoc nip ] ifte - swap set-word-plist ; + swap set-word-plist ; inline PREDICATE: word compound ( obj -- ? ) word-primitive 1 = ; PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ; diff --git a/native/arithmetic.c b/native/arithmetic.c index 0bb13ed4bc..24caa1e9fc 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -91,57 +91,3 @@ void primitive_arithmetic_type(void) dpush(tag_fixnum(type)); } - -bool realp(CELL tagged) -{ - switch(type_of(tagged)) - { - case FIXNUM_TYPE: - case BIGNUM_TYPE: - case RATIO_TYPE: - case FLOAT_TYPE: - return true; - break; - default: - return false; - break; - } -} - -bool zerop(CELL tagged) -{ - switch(type_of(tagged)) - { - case FIXNUM_TYPE: - return tagged == 0; - case BIGNUM_TYPE: - return BIGNUM_ZERO_P((F_ARRAY*)UNTAG(tagged)); - case FLOAT_TYPE: - return ((F_FLOAT*)UNTAG(tagged))->n == 0.0; - case RATIO_TYPE: - case COMPLEX_TYPE: - return false; - default: - type_error(NUMBER_TYPE,tagged); - return false; /* Can't happen */ - } -} - -bool onep(CELL tagged) -{ - switch(type_of(tagged)) - { - case FIXNUM_TYPE: - return tagged == tag_fixnum(1); - case BIGNUM_TYPE: - return BIGNUM_ONE_P((F_ARRAY*)UNTAG(tagged),0); - case FLOAT_TYPE: - return ((F_FLOAT*)UNTAG(tagged))->n == 1.0; - case RATIO_TYPE: - case COMPLEX_TYPE: - return false; - default: - type_error(NUMBER_TYPE,tagged); - return false; /* Can't happen */ - } -} diff --git a/native/arithmetic.h b/native/arithmetic.h index 2c01f86f35..bd98828725 100644 --- a/native/arithmetic.h +++ b/native/arithmetic.h @@ -1,8 +1,3 @@ #include "factor.h" void primitive_arithmetic_type(void); - -bool realp(CELL tagged); - -bool zerop(CELL tagged); -bool onep(CELL tagged); diff --git a/native/array.c b/native/array.c index 35faf04bc8..b725714382 100644 --- a/native/array.c +++ b/native/array.c @@ -1,7 +1,7 @@ #include "factor.h" /* untagged */ -F_ARRAY* allot_array(CELL type, F_FIXNUM capacity) +F_ARRAY* allot_array(CELL type, CELL capacity) { F_ARRAY* array; if(capacity < 0) @@ -12,7 +12,7 @@ F_ARRAY* allot_array(CELL type, F_FIXNUM capacity) } /* untagged */ -F_ARRAY* array(F_FIXNUM capacity, CELL fill) +F_ARRAY* array(CELL capacity, CELL fill) { int i; @@ -24,12 +24,16 @@ F_ARRAY* array(F_FIXNUM capacity, CELL fill) return array; } -F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill) +F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill) { /* later on, do an optimization: if end of array is here, just grow */ int i; + F_ARRAY* new_array; - F_ARRAY* new_array = allot_array(untag_header(array->header),capacity); + if(array->capacity >= capacity) + return array; + + new_array = allot_array(untag_header(array->header),capacity); memcpy(new_array + 1,array + 1,array->capacity * CELLS); @@ -39,7 +43,14 @@ F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill) return new_array; } -F_ARRAY* shrink_array(F_ARRAY* array, F_FIXNUM capacity) +void primitive_grow_array(void) +{ + F_ARRAY* array = untag_array(dpop()); + CELL capacity = to_fixnum(dpop()); + dpush(tag_object(grow_array(array,capacity,F))); +} + +F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity) { F_ARRAY* new_array = allot_array(untag_header(array->header),capacity); memcpy(new_array + 1,array + 1,capacity * CELLS); diff --git a/native/array.h b/native/array.h index 32618f8bd4..74d56506e7 100644 --- a/native/array.h +++ b/native/array.h @@ -10,10 +10,11 @@ INLINE F_ARRAY* untag_array(CELL tagged) return (F_ARRAY*)UNTAG(tagged); /* FIXME */ } -F_ARRAY* allot_array(CELL type, F_FIXNUM capacity); -F_ARRAY* array(F_FIXNUM capacity, CELL fill); -F_ARRAY* grow_array(F_ARRAY* array, F_FIXNUM capacity, CELL fill); -F_ARRAY* shrink_array(F_ARRAY* array, F_FIXNUM capacity); +F_ARRAY* allot_array(CELL type, CELL capacity); +F_ARRAY* array(CELL capacity, CELL fill); +F_ARRAY* grow_array(F_ARRAY* array, CELL capacity, CELL fill); +void primitive_grow_array(void); +F_ARRAY* shrink_array(F_ARRAY* array, CELL capacity); #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS) diff --git a/native/compiler.c b/native/compiler.c index 36193c1842..98b15a03d2 100644 --- a/native/compiler.c +++ b/native/compiler.c @@ -6,28 +6,6 @@ void init_compiler(void) literal_top = compiling.base; } -void check_compiled_offset(CELL offset) -{ - if(offset < compiling.base || offset >= compiling.limit) - range_error(F,0,to_integer(offset),compiling.limit); -} - -void primitive_set_compiled_byte(void) -{ - CELL offset = unbox_integer(); - BYTE b = to_fixnum(dpop()); - check_compiled_offset(offset); - bput(offset,b); -} - -void primitive_set_compiled_cell(void) -{ - CELL offset = unbox_integer(); - CELL c = to_fixnum(dpop()); - check_compiled_offset(offset); - put(offset,c); -} - void primitive_compiled_offset(void) { box_integer(compiling.here); @@ -36,7 +14,6 @@ void primitive_compiled_offset(void) void primitive_set_compiled_offset(void) { CELL offset = unbox_integer(); - check_compiled_offset(offset); compiling.here = offset; } @@ -48,16 +25,12 @@ void primitive_literal_top(void) void primitive_set_literal_top(void) { CELL offset = unbox_integer(); - check_compiled_offset(offset); literal_top = offset; } void collect_literals(void) { - CELL i = compiling.base; - while(i < literal_top) - { + CELL i; + for(i = compiling.base; i < literal_top; i += CELLS) copy_object((CELL*)i); - i += CELLS; - } } diff --git a/native/compiler.h b/native/compiler.h index 539b53aa96..cc187d19bb 100644 --- a/native/compiler.h +++ b/native/compiler.h @@ -2,8 +2,6 @@ ZONE compiling; CELL literal_top; void init_compiler(void); -void primitive_set_compiled_byte(void); -void primitive_set_compiled_cell(void); void primitive_compiled_offset(void); void primitive_set_compiled_offset(void); void primitive_literal_top(void); diff --git a/native/complex.c b/native/complex.c index 0000775970..a5fdced559 100644 --- a/native/complex.c +++ b/native/complex.c @@ -1,65 +1,15 @@ #include "factor.h" -void primitive_real(void) -{ - switch(type_of(dpeek())) - { - case FIXNUM_TYPE: - case BIGNUM_TYPE: - case FLOAT_TYPE: - case RATIO_TYPE: - /* No op */ - break; - case COMPLEX_TYPE: - drepl(untag_complex(dpeek())->real); - break; - default: - type_error(NUMBER_TYPE,dpeek()); - break; - } -} - -void primitive_imaginary(void) -{ - switch(type_of(dpeek())) - { - case FIXNUM_TYPE: - case BIGNUM_TYPE: - case FLOAT_TYPE: - case RATIO_TYPE: - drepl(tag_fixnum(0)); - break; - case COMPLEX_TYPE: - drepl(untag_complex(dpeek())->imaginary); - break; - default: - type_error(NUMBER_TYPE,dpeek()); - break; - } -} - void primitive_from_rect(void) { - CELL imaginary, real; + CELL imaginary = dpop(); + CELL real = dpop(); + F_COMPLEX* complex; maybe_garbage_collection(); - imaginary = dpop(); - real = dpop(); - - if(!realp(imaginary)) - type_error(REAL_TYPE,imaginary); - - if(!realp(real)) - type_error(REAL_TYPE,real); - - if(zerop(imaginary)) - dpush(real); - else - { - F_COMPLEX* complex = allot(sizeof(F_COMPLEX)); - complex->real = real; - complex->imaginary = imaginary; - dpush(tag_complex(complex)); - } + complex = allot(sizeof(F_COMPLEX)); + complex->real = real; + complex->imaginary = imaginary; + dpush(tag_complex(complex)); } diff --git a/native/complex.h b/native/complex.h index 4fc174e78d..247b969659 100644 --- a/native/complex.h +++ b/native/complex.h @@ -3,17 +3,9 @@ typedef struct { CELL imaginary; } F_COMPLEX; -INLINE F_COMPLEX* untag_complex(CELL tagged) -{ - type_check(COMPLEX_TYPE,tagged); - return (F_COMPLEX*)UNTAG(tagged); -} - INLINE CELL tag_complex(F_COMPLEX* complex) { return RETAG(complex,COMPLEX_TYPE); } -void primitive_real(void); -void primitive_imaginary(void); void primitive_from_rect(void); diff --git a/native/cons.c b/native/cons.c index 690cd810d4..b139f3fc3b 100644 --- a/native/cons.c +++ b/native/cons.c @@ -17,12 +17,7 @@ void primitive_cons(void) dpush(cons(car,cdr)); } -void primitive_car(void) +void primitive_to_cons(void) { - drepl(car(dpeek())); -} - -void primitive_cdr(void) -{ - drepl(cdr(dpeek())); + type_check(CONS_TYPE,dpeek()); } diff --git a/native/cons.h b/native/cons.h index 6b7730bdbc..6af6f51b82 100644 --- a/native/cons.h +++ b/native/cons.h @@ -27,5 +27,4 @@ INLINE CELL cdr(CELL cons) } void primitive_cons(void); -void primitive_car(void); -void primitive_cdr(void); +void primitive_to_cons(void); diff --git a/native/factor.h b/native/factor.h index ffe2776044..8b3970ae91 100644 --- a/native/factor.h +++ b/native/factor.h @@ -113,6 +113,7 @@ typedef unsigned char BYTE; #include "word.h" #include "run.h" #include "signal.h" +#include "cons.h" #include "fixnum.h" #include "array.h" #include "s48_bignumint.h" @@ -132,7 +133,6 @@ typedef unsigned char BYTE; #include "write.h" #include "file.h" #include "socket.h" -#include "cons.h" #include "image.h" #include "primitives.h" #include "vector.h" diff --git a/native/float.c b/native/float.c index 4d90e82681..b6b8b00e16 100644 --- a/native/float.c +++ b/native/float.c @@ -59,18 +59,6 @@ void primitive_float_to_str(void) box_c_string(tmp); } -void primitive_float_to_bits(void) -{ - double f; - int64_t f_raw; - - maybe_garbage_collection(); - - f = untag_float(dpeek()); - f_raw = *(int64_t*)&f; - drepl(tag_object(s48_long_long_to_bignum(f_raw))); -} - #define GC_AND_POP_FLOATS(x,y) \ double x, y; \ maybe_garbage_collection(); \ diff --git a/native/primitives.c b/native/primitives.c index 406da752ae..111b83144f 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -8,14 +8,9 @@ XT primitives[] = { primitive_call, primitive_ifte, primitive_cons, - primitive_car, - primitive_cdr, primitive_vector, - primitive_vector_length, - primitive_set_vector_length, primitive_vector_nth, primitive_set_vector_nth, - primitive_string_length, primitive_string_nth, primitive_string_compare, primitive_string_eq, @@ -38,14 +33,9 @@ XT primitives[] = { primitive_to_fixnum, primitive_to_bignum, primitive_to_float, - primitive_numerator, - primitive_denominator, primitive_from_fraction, primitive_str_to_float, primitive_float_to_str, - primitive_float_to_bits, - primitive_real, - primitive_imaginary, primitive_from_rect, primitive_fixnum_eq, primitive_fixnum_add, @@ -103,21 +93,9 @@ XT primitives[] = { primitive_fsinh, primitive_fsqrt, primitive_word, - primitive_word_hashcode, - primitive_word_xt, - primitive_set_word_xt, - primitive_word_primitive, - primitive_set_word_primitive, - primitive_word_parameter, - primitive_set_word_parameter, - primitive_word_plist, - primitive_set_word_plist, + primitive_update_xt, primitive_call_profiling, - primitive_word_call_count, - primitive_set_word_call_count, primitive_allot_profiling, - primitive_word_allot_count, - primitive_set_word_allot_count, primitive_word_compiledp, primitive_drop, primitive_dup, @@ -167,8 +145,6 @@ XT primitives[] = { primitive_cd, primitive_compiled_offset, primitive_set_compiled_offset, - primitive_set_compiled_cell, - primitive_set_compiled_byte, primitive_literal_top, primitive_set_literal_top, primitive_address, @@ -192,6 +168,15 @@ XT primitives[] = { primitive_memory_to_string, primitive_local_alienp, primitive_alien_address, + primitive_to_cons, + primitive_to_vector, + primitive_to_string, + primitive_to_word, + primitive_slot, + primitive_set_slot, + primitive_integer_slot, + primitive_set_integer_slot, + primitive_grow_array }; CELL primitive_to_xt(CELL primitive) diff --git a/native/primitives.h b/native/primitives.h index 1aa49ac281..ea9414b4d8 100644 --- a/native/primitives.h +++ b/native/primitives.h @@ -1,4 +1,4 @@ extern XT primitives[]; -#define PRIMITIVE_COUNT 192 +#define PRIMITIVE_COUNT 195 CELL primitive_to_xt(CELL primitive); diff --git a/native/ratio.c b/native/ratio.c index e3e0a5caa6..36fb921da1 100644 --- a/native/ratio.c +++ b/native/ratio.c @@ -4,55 +4,14 @@ library implementation, to avoid breaking invariants. */ void primitive_from_fraction(void) { - CELL numerator, denominator; + CELL denominator = dpop(); + CELL numerator = dpop(); + F_RATIO* ratio; maybe_garbage_collection(); - denominator = dpop(); - numerator = dpop(); - if(zerop(denominator)) - raise(SIGFPE); - if(onep(denominator)) - dpush(numerator); - else - { - F_RATIO* ratio = allot(sizeof(F_RATIO)); - ratio->numerator = numerator; - ratio->denominator = denominator; - dpush(tag_ratio(ratio)); - } -} - -void primitive_numerator(void) -{ - switch(type_of(dpeek())) - { - case FIXNUM_TYPE: - case BIGNUM_TYPE: - /* No op */ - break; - case RATIO_TYPE: - drepl(untag_ratio(dpeek())->numerator); - break; - default: - type_error(RATIONAL_TYPE,dpeek()); - break; - } -} - -void primitive_denominator(void) -{ - switch(type_of(dpeek())) - { - case FIXNUM_TYPE: - case BIGNUM_TYPE: - drepl(tag_fixnum(1)); - break; - case RATIO_TYPE: - drepl(untag_ratio(dpeek())->denominator); - break; - default: - type_error(RATIONAL_TYPE,dpeek()); - break; - } + ratio = allot(sizeof(F_RATIO)); + ratio->numerator = numerator; + ratio->denominator = denominator; + dpush(tag_ratio(ratio)); } diff --git a/native/ratio.h b/native/ratio.h index 3cf91f9eac..464a675d8d 100644 --- a/native/ratio.h +++ b/native/ratio.h @@ -3,17 +3,9 @@ typedef struct { CELL denominator; } F_RATIO; -INLINE F_RATIO* untag_ratio(CELL tagged) -{ - type_check(RATIO_TYPE,tagged); - return (F_RATIO*)UNTAG(tagged); -} - INLINE CELL tag_ratio(F_RATIO* ratio) { return RETAG(ratio,RATIO_TYPE); } -void primitive_numerator(void); -void primitive_denominator(void); void primitive_from_fraction(void); diff --git a/native/sbuf.c b/native/sbuf.c index 7881829f3a..63f288f282 100644 --- a/native/sbuf.c +++ b/native/sbuf.c @@ -168,7 +168,7 @@ void primitive_sbuf_eq(void) { F_SBUF* s1 = untag_sbuf(dpop()); CELL with = dpop(); - if(typep(SBUF_TYPE,with)) + if(type_of(with) == SBUF_TYPE) dpush(tag_boolean(sbuf_eq(s1,(F_SBUF*)UNTAG(with)))); else dpush(F); diff --git a/native/string.c b/native/string.c index b888406814..19a7c4a776 100644 --- a/native/string.c +++ b/native/string.c @@ -139,11 +139,6 @@ BYTE* unbox_c_string(void) return to_c_string(untag_string(dpop())); } -void primitive_string_length(void) -{ - drepl(tag_fixnum(untag_string(dpeek())->capacity)); -} - void primitive_string_nth(void) { F_STRING* string = untag_string(dpop()); @@ -205,7 +200,7 @@ void primitive_string_eq(void) { F_STRING* s1 = untag_string(dpop()); CELL with = dpop(); - if(typep(STRING_TYPE,with)) + if(type_of(with) == STRING_TYPE) dpush(tag_boolean(string_eq(s1,(F_STRING*)UNTAG(with)))); else dpush(F); @@ -349,3 +344,8 @@ void primitive_string_reverse(void) rehash_string(s); drepl(tag_object(s)); } + +void primitive_to_string(void) +{ + type_check(STRING_TYPE,dpeek()); +} diff --git a/native/string.h b/native/string.h index 4e48f20c65..1e84a62de6 100644 --- a/native/string.h +++ b/native/string.h @@ -42,7 +42,6 @@ INLINE void set_string_nth(F_STRING* string, CELL index, uint16_t value) cput(SREF(string,index),value); } -void primitive_string_length(void); void primitive_string_nth(void); F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len); F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2); @@ -54,3 +53,4 @@ void primitive_substring(void); void string_reverse(F_STRING* s, int len); F_STRING* string_clone(F_STRING* s, int len); void primitive_string_reverse(void); +void primitive_to_string(void); diff --git a/native/types.c b/native/types.c index 2ed580cffd..13b9c90d9e 100644 --- a/native/types.c +++ b/native/types.c @@ -1,10 +1,5 @@ #include "factor.h" -bool typep(CELL type, CELL tagged) -{ - return type_of(tagged) == type; -} - /* * It is up to the caller to fill in the object's fields in a meaningful * fashion! @@ -102,3 +97,35 @@ void primitive_type(void) { drepl(tag_fixnum(type_of(dpeek()))); } + +#define SLOT(obj,slot) UNTAG(obj) + slot * CELLS + +void primitive_slot(void) +{ + F_FIXNUM slot = untag_fixnum_fast(dpop()); + CELL obj = dpop(); + dpush(get(SLOT(obj,slot))); +} + +void primitive_set_slot(void) +{ + F_FIXNUM slot = untag_fixnum_fast(dpop()); + CELL obj = dpop(); + CELL value = dpop(); + put(SLOT(obj,slot),value); +} + +void primitive_integer_slot(void) +{ + F_FIXNUM slot = untag_fixnum_fast(dpop()); + CELL obj = dpop(); + dpush(tag_integer(get(SLOT(obj,slot)))); +} + +void primitive_set_integer_slot(void) +{ + F_FIXNUM slot = untag_fixnum_fast(dpop()); + CELL obj = dpop(); + F_FIXNUM value = to_integer(dpop()); + put(SLOT(obj,slot),value); +} diff --git a/native/types.h b/native/types.h index c2f6c9e88a..8ff015d2f7 100644 --- a/native/types.h +++ b/native/types.h @@ -38,13 +38,8 @@ CELL T; /* Pseudo-types. For error reporting only. */ #define INTEGER_TYPE 100 /* F_FIXNUM or BIGNUM */ -#define RATIONAL_TYPE 101 /* INTEGER or F_RATIO */ -#define REAL_TYPE 102 /* RATIONAL or F_FLOAT */ -#define NUMBER_TYPE 103 /* F_COMPLEX or REAL */ #define TEXT_TYPE 104 /* F_FIXNUM or F_STRING */ -bool typep(CELL type, CELL tagged); - INLINE CELL tag_header(CELL cell) { return RETAG(cell << TAG_BITS,HEADER_TYPE); @@ -117,3 +112,8 @@ INLINE CELL type_of(CELL tagged) else return tag; } + +void primitive_slot(void); +void primitive_set_slot(void); +void primitive_integer_slot(void); +void primitive_set_integer_slot(void); diff --git a/native/unix/io.c b/native/unix/io.c index 894f52afff..37db181e59 100644 --- a/native/unix/io.c +++ b/native/unix/io.c @@ -126,7 +126,7 @@ bool set_up_fd_set(fd_set* fdset, int fd_count, IO_TASK* io_tasks, for(i = 0; i < fd_count; i++) { - if(typep(PORT_TYPE,io_tasks[i].port)) + if(type_of(io_tasks[i].port) == PORT_TYPE) { if(untag_port(io_tasks[i].port)->closed) *closed = true; @@ -205,7 +205,7 @@ CELL perform_io_tasks(fd_set* fdset, IO_TASK* io_tasks, int* fd_count) { IO_TASK io_task = io_tasks[i]; - if(typep(PORT_TYPE,io_task.port)) + if(type_of(io_task.port) == PORT_TYPE) { F_PORT* port = untag_port(io_task.port); if(port->closed) diff --git a/native/vector.c b/native/vector.c index a805036146..2c8a19624b 100644 --- a/native/vector.c +++ b/native/vector.c @@ -14,28 +14,9 @@ void primitive_vector(void) drepl(tag_object(vector(to_fixnum(dpeek())))); } -void primitive_vector_length(void) +void primitive_to_vector(void) { - drepl(tag_fixnum(untag_vector(dpeek())->top)); -} - -void primitive_set_vector_length(void) -{ - F_VECTOR* vector; - F_FIXNUM length; - F_ARRAY* array; - - maybe_garbage_collection(); - - vector = untag_vector(dpop()); - length = to_fixnum(dpop()); - array = untag_array(vector->array); - - if(length < 0) - range_error(tag_object(vector),0,tag_fixnum(length),vector->top); - vector->top = length; - if(length > array->capacity) - vector->array = tag_object(grow_array(array,length,F)); + type_check(VECTOR_TYPE,dpeek()); } void primitive_vector_nth(void) diff --git a/native/vector.h b/native/vector.h index 1bbd5916af..a851779c16 100644 --- a/native/vector.h +++ b/native/vector.h @@ -16,8 +16,7 @@ INLINE F_VECTOR* untag_vector(CELL tagged) F_VECTOR* vector(F_FIXNUM capacity); void primitive_vector(void); -void primitive_vector_length(void); -void primitive_set_vector_length(void); +void primitive_to_vector(void); void primitive_vector_nth(void); void vector_ensure_capacity(F_VECTOR* vector, CELL index); void primitive_set_vector_nth(void); diff --git a/native/word.c b/native/word.c index 41952ef772..d02f0600ee 100644 --- a/native/word.c +++ b/native/word.c @@ -1,19 +1,5 @@ #include "factor.h" -F_WORD* word(CELL primitive, CELL parameter, CELL plist) -{ - F_WORD* word = allot_object(WORD_TYPE,sizeof(F_WORD)); - word->hashcode = (CELL)word; /* initial address */ - word->xt = primitive_to_xt(primitive); - word->primitive = primitive; - word->parameter = parameter; - word->plist = plist; - word->call_count = 0; - word->allot_count = 0; - - return word; -} - /* When a word is executed we jump to the value of the xt field. However this value is an unportable function pointer, so in the image we store a primitive number that indexes a list of xts. */ @@ -25,87 +11,24 @@ void update_xt(F_WORD* word) /* ( primitive parameter plist -- word ) */ void primitive_word(void) { - CELL plist, parameter; - F_FIXNUM primitive; + F_WORD* word; maybe_garbage_collection(); - plist = dpop(); - parameter = dpop(); - primitive = to_fixnum(dpop()); - dpush(tag_word(word(primitive,parameter,plist))); + word = allot_object(WORD_TYPE,sizeof(F_WORD)); + word->hashcode = (CELL)word; /* initial address */ + word->xt = (CELL)undefined; + word->primitive = 0; + word->parameter = F; + word->plist = F; + word->call_count = 0; + word->allot_count = 0; + dpush(tag_word(word)); } -void primitive_word_hashcode(void) +void primitive_update_xt(void) { - drepl(tag_fixnum(untag_word(dpeek())->hashcode)); -} - -void primitive_word_xt(void) -{ - drepl(tag_cell(untag_word(dpeek())->xt)); -} - -void primitive_set_word_xt(void) -{ - F_WORD* word = untag_word(dpop()); - word->xt = unbox_integer(); -} - -void primitive_word_primitive(void) -{ - drepl(tag_fixnum(untag_word(dpeek())->primitive)); -} - -void primitive_set_word_primitive(void) -{ - F_WORD* word = untag_word(dpop()); - word->primitive = to_fixnum(dpop()); - update_xt(word); -} - -void primitive_word_parameter(void) -{ - drepl(untag_word(dpeek())->parameter); -} - -void primitive_set_word_parameter(void) -{ - F_WORD* word = untag_word(dpop()); - word->parameter = dpop(); -} - -void primitive_word_plist(void) -{ - drepl(untag_word(dpeek())->plist); -} - -void primitive_set_word_plist(void) -{ - F_WORD* word = untag_word(dpop()); - word->plist = dpop(); -} - -void primitive_word_call_count(void) -{ - drepl(tag_cell(untag_word(dpeek())->call_count)); -} - -void primitive_set_word_call_count(void) -{ - F_WORD* word = untag_word(dpop()); - word->call_count = to_fixnum(dpop()); -} - -void primitive_word_allot_count(void) -{ - drepl(tag_cell(untag_word(dpeek())->allot_count)); -} - -void primitive_set_word_allot_count(void) -{ - F_WORD* word = untag_word(dpop()); - word->allot_count = to_fixnum(dpop()); + update_xt(untag_word(dpop())); } void primitive_word_compiledp(void) @@ -114,6 +37,11 @@ void primitive_word_compiledp(void) box_boolean(word->xt != (CELL)docol && word->xt != (CELL)dosym); } +void primitive_to_word(void) +{ + type_check(WORD_TYPE,dpeek()); +} + void fixup_word(F_WORD* word) { update_xt(word); diff --git a/native/word.h b/native/word.h index 89cdcb92c8..afbbf0d651 100644 --- a/native/word.h +++ b/native/word.h @@ -30,22 +30,10 @@ INLINE CELL tag_word(F_WORD* word) return RETAG(word,WORD_TYPE); } -F_WORD* word(CELL primitive, CELL parameter, CELL plist); void update_xt(F_WORD* word); void primitive_word(void); -void primitive_word_hashcode(void); -void primitive_word_primitive(void); -void primitive_set_word_primitive(void); -void primitive_word_xt(void); -void primitive_set_word_xt(void); -void primitive_word_parameter(void); -void primitive_set_word_parameter(void); -void primitive_word_plist(void); -void primitive_set_word_plist(void); -void primitive_word_call_count(void); -void primitive_set_word_call_count(void); -void primitive_word_allot_count(void); -void primitive_set_word_allot_count(void); +void primitive_update_xt(void); void primitive_word_compiledp(void); +void primitive_to_word(void); void fixup_word(F_WORD* word); void collect_word(F_WORD* word);