From 6c6c23ce71be514e3bc1fb514b69971cff11bb2c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 15 Dec 2004 21:57:29 +0000 Subject: [PATCH] reworked bootstrap code, a lot of cleanups --- examples/more-random.factor | 11 + factor/jedit/FactorPlugin.java | 64 ++-- library/bootstrap/boot-stage2.factor | 4 +- library/bootstrap/boot.factor | 111 +++--- library/bootstrap/cross-compiler.factor | 431 ------------------------ library/bootstrap/image.factor | 145 ++++---- library/bootstrap/init.factor | 11 +- library/bootstrap/primitives.factor | 242 +++++++++++++ library/cli.factor | 2 +- library/combinators.factor | 1 + library/compiler/alien.factor | 4 + library/compiler/linearizer.factor | 2 +- library/cons.factor | 57 ++++ library/errors.factor | 3 + library/generic/generic.factor | 3 + library/generic/traits.factor | 3 - library/hashtables.factor | 24 ++ library/io/files.factor | 2 +- library/io/io-internals.factor | 3 + library/io/stream.factor | 6 +- library/kernel.factor | 13 + library/lists.factor | 70 ---- library/math/generic.factor | 20 ++ library/namespaces.factor | 2 +- library/sdl/hsv.factor | 13 +- library/strings.factor | 9 +- library/syntax/parse-syntax.factor | 81 +---- library/syntax/parser.factor | 78 ++++- library/syntax/unparser.factor | 28 ++ library/test/benchmark/sort.factor | 2 +- library/test/inspector.factor | 2 +- library/test/lists/combinators.factor | 6 +- library/test/lists/lists.factor | 4 - library/test/namespaces.factor | 2 +- library/test/test.factor | 3 +- library/test/words.factor | 2 - library/types.factor | 81 ----- library/vectors.factor | 12 + library/vocabularies.factor | 78 ++++- library/words.factor | 81 +---- native/types.h | 6 + 41 files changed, 796 insertions(+), 926 deletions(-) delete mode 100644 library/bootstrap/cross-compiler.factor create mode 100644 library/bootstrap/primitives.factor delete mode 100644 library/types.factor diff --git a/examples/more-random.factor b/examples/more-random.factor index bbba2966fe..c9d9f3357e 100644 --- a/examples/more-random.factor +++ b/examples/more-random.factor @@ -5,6 +5,13 @@ USE: math USE: test USE: namespaces +: nth ( n list -- list[n] ) + #! nth element of a proper list. + #! Supplying n <= 0 pushes the first element of the list. + #! Supplying an argument beyond the end of the list raises + #! an error. + swap [ cdr ] times car ; + : random-element ( list -- random ) #! Returns a random element from the given list. dup >r length pred 0 swap random-int r> nth ; @@ -85,4 +92,8 @@ USE: namespaces "random-pairs" get check-random-subset ] unit-test + + [ 1 ] [ -1 [ 1 2 ] nth ] unit-test + [ 1 ] [ 0 [ 1 2 ] nth ] unit-test + [ 2 ] [ 1 [ 1 2 ] nth ] unit-test ] with-scope diff --git a/factor/jedit/FactorPlugin.java b/factor/jedit/FactorPlugin.java index 23cbadc477..e556b70560 100644 --- a/factor/jedit/FactorPlugin.java +++ b/factor/jedit/FactorPlugin.java @@ -170,15 +170,40 @@ public class FactorPlugin extends EditPlugin getExternalInstance().eval(cmd); } //}}} + //{{{ lookupWord() method + /** + * Look up the given Factor word in the vocabularies USE:d in the given view. + */ + public static FactorWord lookupWord(View view, String word) + { + SideKickParsedData data = SideKickParsedData.getParsedData(view); + if(data instanceof FactorParsedData) + { + FactorParsedData fdata = (FactorParsedData)data; + return getExternalInstance().searchVocabulary(fdata.use,word); + } + else + return null; + } //}}} + //{{{ factorWord() method /** - * Build a Factor expression for pushing the selected word on the stack + * Look up the given Factor word in the vocabularies USE:d in the given view. */ - public static String factorWord(FactorWord word) + public static String factorWord(View view, String word) { - return FactorReader.unparseObject(word.name) - + " [ " + FactorReader.unparseObject(word.vocabulary) - + " ] search"; + SideKickParsedData data = SideKickParsedData + .getParsedData(view); + if(data instanceof FactorParsedData) + { + FactorParsedData fdata = (FactorParsedData)data; + return "\"" + + FactorReader.charsToEscapes(word) + + "\" " + FactorReader.unparseObject(fdata.use) + + " search"; + } + else + return null; } //}}} //{{{ factorWord() method @@ -188,21 +213,22 @@ public class FactorPlugin extends EditPlugin public static String factorWord(View view) { JEditTextArea textArea = view.getTextArea(); - SideKickParsedData data = SideKickParsedData - .getParsedData(view); - if(data instanceof FactorParsedData) - { - FactorParsedData fdata = (FactorParsedData)data; - String word = FactorPlugin.getWordAtCaret(textArea); - if(word == null) - return null; - return "\"" - + FactorReader.charsToEscapes(word) - + "\" " + FactorReader.unparseObject(fdata.use) - + " search"; - } - else + String word = FactorPlugin.getWordAtCaret(textArea); + if(word == null) return null; + else + return factorWord(view,word); + } //}}} + + //{{{ factorWord() method + /** + * Build a Factor expression for pushing the selected word on the stack + */ + public static String factorWord(FactorWord word) + { + return FactorReader.unparseObject(word.name) + + " [ " + FactorReader.unparseObject(word.vocabulary) + + " ] search"; } //}}} //{{{ factorWordOutputOp() method diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 4dcba8c05d..4471d3012b 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -32,6 +32,7 @@ USE: parser USE: stdio "Cold boot in progress..." print + [ "/version.factor" "/library/stack.factor" @@ -41,7 +42,6 @@ USE: stdio "/library/generic/builtin.factor" "/library/generic/predicate.factor" "/library/generic/traits.factor" - "/library/types.factor" "/library/math/math.factor" "/library/cons.factor" "/library/combinators.factor" @@ -117,6 +117,7 @@ USE: stdio "/library/compiler/xt.factor" "/library/compiler/optimizer.factor" "/library/compiler/linearizer.factor" + "/library/compiler/simplifier.factor" "/library/compiler/generator.factor" "/library/compiler/compiler.factor" "/library/compiler/alien-types.factor" @@ -131,7 +132,6 @@ USE: stdio "/library/sdl/hsv.factor" "/library/bootstrap/image.factor" - "/library/bootstrap/cross-compiler.factor" "/library/httpd/url-encoding.factor" "/library/httpd/html-tags.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 564b633a27..e39c467513 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -32,57 +32,66 @@ USE: namespaces USE: stdio USE: kernel USE: vectors +USE: words +USE: hashtables -primitives, -[ - "/version.factor" - "/library/stack.factor" - "/library/kernel.factor" - "/library/generic/generic.factor" - "/library/generic/object.factor" - "/library/generic/builtin.factor" - "/library/generic/predicate.factor" - "/library/generic/traits.factor" - "/library/types.factor" - "/library/combinators.factor" - "/library/math/math.factor" - "/library/cons.factor" - "/library/logic.factor" - "/library/vectors.factor" - "/library/lists.factor" - "/library/assoc.factor" - "/library/math/arithmetic.factor" - "/library/math/math-combinators.factor" - "/library/strings.factor" - "/library/hashtables.factor" - "/library/namespaces.factor" - "/library/list-namespaces.factor" - "/library/sbuf.factor" - "/library/continuations.factor" - "/library/errors.factor" - "/library/threads.factor" - "/library/io/stream.factor" - "/library/io/io-internals.factor" - "/library/io/stream-impl.factor" - "/library/io/stdio.factor" - "/library/words.factor" - "/library/vocabularies.factor" - "/library/syntax/parse-numbers.factor" - "/library/syntax/parser.factor" - "/library/syntax/parse-syntax.factor" - "/library/syntax/parse-stream.factor" - "/library/math/generic.factor" - "/library/bootstrap/init.factor" -] [ - cross-compile-resource -] each +"/library/bootstrap/primitives.factor" run-resource +"/version.factor" run-resource +"/library/stack.factor" run-resource +"/library/combinators.factor" run-resource +"/library/kernel.factor" run-resource +"/library/logic.factor" run-resource +"/library/cons.factor" run-resource +"/library/assoc.factor" run-resource +"/library/math/generic.factor" run-resource +"/library/words.factor" run-resource +"/library/math/arithmetic.factor" run-resource +"/library/math/math-combinators.factor" run-resource +"/library/math/math.factor" run-resource +"/library/lists.factor" run-resource +"/library/vectors.factor" run-resource +"/library/strings.factor" run-resource +"/library/hashtables.factor" run-resource +"/library/namespaces.factor" run-resource +"/library/list-namespaces.factor" run-resource +"/library/sbuf.factor" run-resource +"/library/errors.factor" run-resource +"/library/continuations.factor" run-resource +"/library/threads.factor" run-resource +"/library/io/stream.factor" run-resource +"/library/io/stdio.factor" run-resource +"/library/io/io-internals.factor" run-resource +"/library/io/stream-impl.factor" run-resource +"/library/vocabularies.factor" run-resource +"/library/syntax/parse-numbers.factor" run-resource +"/library/syntax/parser.factor" run-resource +"/library/syntax/parse-stream.factor" run-resource -IN: init -DEFER: boot +! A bootstrapping trick. See doc/bootstrap.txt. +vocabularies get [ + "generic" off +] bind -[ - boot - "Good morning!" print - flush - "/library/bootstrap/boot-stage2.factor" run-resource -] boot-quot set +"/library/generic/generic.factor" run-resource +"/library/generic/object.factor" run-resource +"/library/generic/builtin.factor" run-resource +"/library/generic/predicate.factor" run-resource +"/library/generic/traits.factor" run-resource + +"/library/bootstrap/init.factor" run-resource + +! A bootstrapping trick. See doc/bootstrap.txt. +"/library/syntax/parse-syntax.factor" run-resource + +vocabularies get [ + "!syntax" get "syntax" set + "!syntax" off + + "syntax" get [ + cdr dup word? [ + "syntax" "vocabulary" set-word-property + ] [ + drop + ] ifte + ] hash-each +] bind diff --git a/library/bootstrap/cross-compiler.factor b/library/bootstrap/cross-compiler.factor deleted file mode 100644 index 6325cc5132..0000000000 --- a/library/bootstrap/cross-compiler.factor +++ /dev/null @@ -1,431 +0,0 @@ -! :folding=none:collapseFolds=1: - -! $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. - -USE: errors -USE: kernel -USE: lists -USE: math -USE: math-internals -USE: namespaces -USE: parser -USE: stdio -USE: streams -USE: strings -USE: vectors -USE: words - -IN: alien -DEFER: dlopen -DEFER: dlsym -DEFER: dlsym-self -DEFER: dlclose -DEFER: -DEFER: -DEFER: alien-cell -DEFER: set-alien-cell -DEFER: alien-4 -DEFER: set-alien-4 -DEFER: alien-2 -DEFER: set-alien-2 -DEFER: alien-1 -DEFER: set-alien-1 - -IN: compiler -DEFER: set-compiled-byte -DEFER: set-compiled-cell -DEFER: compiled-offset -DEFER: set-compiled-offset -DEFER: literal-top -DEFER: set-literal-top - -IN: kernel -DEFER: gc-time -DEFER: getenv -DEFER: setenv -DEFER: save-image -DEFER: room -DEFER: os-env -DEFER: type -DEFER: size -DEFER: address -DEFER: heap-stats -DEFER: drop -DEFER: dup -DEFER: over -DEFER: pick -DEFER: swap -DEFER: >r -DEFER: r> -DEFER: ifte -DEFER: call -DEFER: datastack -DEFER: callstack -DEFER: set-datastack -DEFER: set-callstack - -IN: strings -DEFER: str= -DEFER: str-hashcode -DEFER: sbuf= -DEFER: sbuf-hashcode -DEFER: sbuf-clone - -IN: files -DEFER: stat -DEFER: (directory) -DEFER: cwd -DEFER: cd - -IN: io-internals -DEFER: open-file -DEFER: client-socket -DEFER: server-socket -DEFER: close-port -DEFER: add-accept-io-task -DEFER: accept-fd -DEFER: can-read-line? -DEFER: add-read-line-io-task -DEFER: read-line-fd-8 -DEFER: can-read-count? -DEFER: add-read-count-io-task -DEFER: read-count-fd-8 -DEFER: can-write? -DEFER: add-write-io-task -DEFER: write-fd-8 -DEFER: add-copy-io-task -DEFER: pending-io-error -DEFER: next-io-task - -IN: math -DEFER: fraction> - -IN: math-internals -DEFER: arithmetic-type -DEFER: fixnum= -DEFER: fixnum+ -DEFER: fixnum- -DEFER: fixnum* -DEFER: fixnum/i -DEFER: fixnum/f -DEFER: fixnum-mod -DEFER: fixnum/mod -DEFER: fixnum-bitand -DEFER: fixnum-bitor -DEFER: fixnum-bitxor -DEFER: fixnum-bitnot -DEFER: fixnum-shift -DEFER: fixnum< -DEFER: fixnum<= -DEFER: fixnum> -DEFER: fixnum>= -DEFER: bignum= -DEFER: bignum+ -DEFER: bignum- -DEFER: bignum* -DEFER: bignum/i -DEFER: bignum/f -DEFER: bignum-mod -DEFER: bignum/mod -DEFER: bignum-bitand -DEFER: bignum-bitor -DEFER: bignum-bitxor -DEFER: bignum-bitnot -DEFER: bignum-shift -DEFER: bignum< -DEFER: bignum<= -DEFER: bignum> -DEFER: bignum>= -DEFER: float= -DEFER: float+ -DEFER: float- -DEFER: float* -DEFER: float/f -DEFER: float< -DEFER: float<= -DEFER: float> -DEFER: float>= -DEFER: facos -DEFER: fasin -DEFER: fatan -DEFER: fatan2 -DEFER: fcos -DEFER: fexp -DEFER: fcosh -DEFER: flog -DEFER: fpow -DEFER: fsin -DEFER: fsinh -DEFER: fsqrt - -IN: parser -DEFER: str>float - -IN: profiler -DEFER: call-profiling -DEFER: call-count -DEFER: set-call-count -DEFER: allot-profiling -DEFER: allot-count -DEFER: set-allot-count - -IN: random -DEFER: init-random -DEFER: (random-int) - -IN: words -DEFER: -DEFER: word-hashcode -DEFER: word-xt -DEFER: set-word-xt -DEFER: word-primitive -DEFER: set-word-primitive -DEFER: word-parameter -DEFER: set-word-parameter -DEFER: word-plist -DEFER: set-word-plist -DEFER: compiled? - -IN: unparser -DEFER: (unparse-float) - -IN: image - -: primitives, ( -- ) - 2 [ - execute - call - ifte - cons - car - cdr - - vector-length - set-vector-length - vector-nth - set-vector-nth - str-length - str-nth - str-compare - str= - str-hashcode - index-of* - substring - str-reverse - - sbuf-length - set-sbuf-length - sbuf-nth - set-sbuf-nth - sbuf-append - sbuf>str - sbuf-reverse - sbuf-clone - sbuf= - sbuf-hashcode - arithmetic-type - number? - >fixnum - >bignum - >float - numerator - denominator - fraction> - str>float - (unparse-float) - float>bits - real - imaginary - rect> - fixnum= - fixnum+ - fixnum- - fixnum* - fixnum/i - fixnum/f - fixnum-mod - fixnum/mod - fixnum-bitand - fixnum-bitor - fixnum-bitxor - fixnum-bitnot - fixnum-shift - fixnum< - fixnum<= - fixnum> - fixnum>= - bignum= - bignum+ - bignum- - bignum* - bignum/i - bignum/f - bignum-mod - bignum/mod - bignum-bitand - bignum-bitor - bignum-bitxor - bignum-bitnot - bignum-shift - bignum< - bignum<= - bignum> - bignum>= - float= - float+ - float- - float* - float/f - float< - float<= - float> - float>= - facos - fasin - fatan - fatan2 - fcos - fexp - fcosh - flog - fpow - fsin - fsinh - fsqrt - - word-hashcode - word-xt - set-word-xt - word-primitive - set-word-primitive - word-parameter - set-word-parameter - word-plist - set-word-plist - call-profiling - call-count - set-call-count - allot-profiling - allot-count - set-allot-count - compiled? - drop - dup - swap - over - pick - >r - r> - eq? - getenv - setenv - open-file - stat - (directory) - garbage-collection - gc-time - save-image - datastack - callstack - set-datastack - set-callstack - exit* - client-socket - server-socket - close-port - add-accept-io-task - accept-fd - can-read-line? - add-read-line-io-task - read-line-fd-8 - can-read-count? - add-read-count-io-task - read-count-fd-8 - can-write? - add-write-io-task - write-fd-8 - add-copy-io-task - pending-io-error - next-io-task - room - os-env - millis - init-random - (random-int) - type - size - cwd - cd - compiled-offset - set-compiled-offset - set-compiled-cell - set-compiled-byte - literal-top - set-literal-top - address - dlopen - dlsym - dlsym-self - dlclose - - - alien-cell - set-alien-cell - alien-4 - set-alien-4 - alien-2 - set-alien-2 - alien-1 - set-alien-1 - heap-stats - throw - ] [ - USE: stack swap succ tuck f define, - ] each drop ; - -: make-image ( name -- ) - #! Make an image for the C interpreter. - [ - "/library/bootstrap/boot.factor" run-resource - ] with-image - - swap write-image ; - -: make-images ( -- ) - "64-bits" off - "big-endian" off "boot.image.le32" make-image - "big-endian" on "boot.image.be32" make-image - "64-bits" on - "big-endian" off "boot.image.le64" make-image - "big-endian" on "boot.image.be64" make-image - "64-bits" off ; - -: cross-compile-resource ( resource -- ) - [ - ! Change behavior of ; and SYMBOL: - [ define, ] "define-hook" set - run-resource - ] with-scope ; diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 4d0afde88c..adc60e4d25 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -55,10 +55,7 @@ USE: test USE: vectors USE: unparser USE: words - -USE: stack -USE: combinators -USE: logic +USE: parser ! The image being constructed; a vector of word-size integers SYMBOL: image @@ -193,24 +190,49 @@ M: f ' ( obj -- ptr ) ( Words ) -: word, ( word -- pointer ) - word-tag here-as >r word-tag >header emit - hashcode emit ( hashcode ) - 0 emit r> ; +: make-plist ( word -- plist ) + [ + dup word-name "name" swons , + dup word-vocabulary "vocabulary" swons , + parsing? [ t "parsing" swons , ] when + ] make-list ; -! This is to handle mutually recursive words +: word, ( word -- ) + [ + word-tag >header , + dup hashcode , + 0 , + dup word-primitive , + dup word-parameter ' , + dup make-plist ' , + 0 , + 0 , + ] make-list + swap word-tag here-as pool-object + [ emit ] each ; + +: word-error ( word msg -- ) + [ + , + dup word-vocabulary , + " " , + word-name , + ] make-string throw ; + +: transfer-word ( word -- word ) + #! This is a hack. See doc/bootstrap.txt. + dup dup word-name swap word-vocabulary unit search + dup [ + nip + ] [ + drop "Missing DEFER: " word-error + ] ifte ; : fixup-word ( word -- offset ) dup pooled-object dup [ nip ] [ - drop - [ - "Not in image: " , - dup word-vocabulary , - " " , - word-name , - ] make-string throw + drop "Not in image: " word-error ] ifte ; : fixup-words ( -- ) @@ -219,7 +241,7 @@ M: f ' ( obj -- ptr ) ] vector-map image set ; M: word ' ( word -- pointer ) - dup pooled-object dup [ nip ] [ drop ] ifte ; + transfer-word dup pooled-object dup [ nip ] [ drop ] ifte ; ( Conses ) @@ -263,40 +285,6 @@ M: string ' ( string -- pointer ) drop dup emit-string dup >r pool-object r> ] ifte ; -( Word definitions ) - -: (vocabulary) ( name -- vocab ) - #! Vocabulary for target image. - dup "vocabularies" get hash dup [ - nip - ] [ - drop >r namespace-buckets dup r> - "vocabularies" get set-hash - ] ifte ; - -: (word+) ( word -- ) - #! Add the word to a vocabulary in the target image. - dup word-name over word-vocabulary - (vocabulary) set-hash ; - -: emit-plist ( word -- plist ) - [ - dup word-name "name" swons , - dup word-vocabulary "vocabulary" swons , - "parsing" word-property [ t "parsing" swons , ] when - ] make-list ' ; - -: define, ( word primitive parameter -- ) - #! Write a word definition to the image. - ' >r >r dup (word+) dup emit-plist >r - dup word, pool-object - r> ( -- plist ) - r> ( primitive -- ) emit - r> ( parameter -- ) emit - ( plist -- ) emit - 0 emit ( padding ) - 0 emit ; - ( Arrays and vectors ) : emit-array ( list -- pointer ) @@ -317,35 +305,29 @@ M: vector ' ( vector -- pointer ) ( End of the image ) -: vocabularies, ( -- ) - #! Produces code with stack effect ( -- vocabularies ). - #! This code sets up vocabulary hash tables. - \ , +: vocabularies, ( vocabularies -- ) [ - "vocabularies" get [ - uncons hash>alist , \ alist>hash , , \ set , - ] hash-each - ] make-list , - \ extend , ; + cdr dup vector? [ + [ + cdr dup word? [ word, ] [ drop ] ifte + ] hash-each + ] [ + drop + ] ifte + ] hash-each ; : global, ( -- ) - #! Produces code with stack effect ( vocabularies -- ). - ' global-offset fixup - "vocabularies" , - \ global , - \ set-hash , ; - -: hash-quot ( -- quot ) - #! Generate a quotation to generate vocabulary and global - #! namespace hashtables. - [ vocabularies, global, ] make-list ; + vocabularies get + dup vocabularies, + [ vocabularies set ] extend ' + global-offset fixup ; : boot, ( quot -- ) - boot-quot get append ' boot-quot-offset fixup ; + boot-quot get ' boot-quot-offset fixup ; : end ( -- ) - hash-quot boot, + global, fixup-words here base - heap-size-offset fixup ; @@ -373,7 +355,6 @@ M: vector ' ( vector -- pointer ) [ 300000 image set 521 "objects" set - namespace-buckets "vocabularies" set ! Note that this is a vector that we can side-effect, ! since ; ends up using this variable from nested ! parser namespaces. @@ -386,3 +367,21 @@ M: vector ' ( vector -- pointer ) [ begin call end ] with-minimal-image ; : test-image ( quot -- ) with-image vector>list . ; + +: make-image ( name -- ) + #! Make an image for the C interpreter. + [ + "/library/bootstrap/boot.factor" run-resource + boot-quot set + ] with-image + + swap write-image ; + +: make-images ( -- ) + "64-bits" off + "big-endian" off "boot.image.le32" make-image + "big-endian" on "boot.image.be32" make-image + "64-bits" on + "big-endian" off "boot.image.le64" make-image + "big-endian" on "boot.image.be64" make-image + "64-bits" off ; diff --git a/library/bootstrap/init.factor b/library/bootstrap/init.factor index 5e394005dd..dcc6f128c3 100644 --- a/library/bootstrap/init.factor +++ b/library/bootstrap/init.factor @@ -26,8 +26,6 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: init -USE: compiler -USE: errors USE: kernel USE: namespaces USE: parser @@ -35,7 +33,6 @@ USE: stdio USE: streams USE: threads USE: words -USE: vectors : boot ( -- ) #! Initialize an interpreter with the basic services. @@ -43,5 +40,11 @@ USE: vectors init-threads init-stdio "HOME" os-env [ "." ] unless* "~" set - "/" "/" set init-search-path ; + +[ + boot + "Good morning!" print + flush + "/library/bootstrap/boot-stage2.factor" run-resource +] diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor new file mode 100644 index 0000000000..5c1d1a400f --- /dev/null +++ b/library/bootstrap/primitives.factor @@ -0,0 +1,242 @@ +! :folding=none:collapseFolds=1: + +! $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: image +USE: kernel +USE: lists +USE: math +USE: namespaces +USE: parser +USE: words +USE: vectors +USE: hashtables + +! Bring up a bare cross-compiling vocabulary. +"syntax" vocab +"generic" vocab + +! This symbol needs the same hashcode in the target as in the +! host. +vocabularies + + vocabularies set +vocabularies get [ + reveal + "generic" set + "syntax" set +] bind + +2 [ + [ "words" | "execute" ] + [ "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=" ] + [ "strings" | "str-hashcode" ] + [ "strings" | "index-of*" ] + [ "strings" | "substring" ] + [ "strings" | "str-reverse" ] + [ "strings" | "" ] + [ "strings" | "sbuf-length" ] + [ "strings" | "set-sbuf-length" ] + [ "strings" | "sbuf-nth" ] + [ "strings" | "set-sbuf-nth" ] + [ "strings" | "sbuf-append" ] + [ "strings" | "sbuf>str" ] + [ "strings" | "sbuf-reverse" ] + [ "strings" | "sbuf-clone" ] + [ "strings" | "sbuf=" ] + [ "strings" | "sbuf-hashcode" ] + [ "math-internals" | "arithmetic-type" ] + [ "math" | "number?" ] + [ "math" | ">fixnum" ] + [ "math" | ">bignum" ] + [ "math" | ">float" ] + [ "math" | "numerator" ] + [ "math" | "denominator" ] + [ "math" | "fraction>" ] + [ "parser" | "str>float" ] + [ "unparser" | "(unparse-float)" ] + [ "math" | "float>bits" ] + [ "math" | "real" ] + [ "math" | "imaginary" ] + [ "math" | "rect>" ] + [ "math-internals" | "fixnum=" ] + [ "math-internals" | "fixnum+" ] + [ "math-internals" | "fixnum-" ] + [ "math-internals" | "fixnum*" ] + [ "math-internals" | "fixnum/i" ] + [ "math-internals" | "fixnum/f" ] + [ "math-internals" | "fixnum-mod" ] + [ "math-internals" | "fixnum/mod" ] + [ "math-internals" | "fixnum-bitand" ] + [ "math-internals" | "fixnum-bitor" ] + [ "math-internals" | "fixnum-bitxor" ] + [ "math-internals" | "fixnum-bitnot" ] + [ "math-internals" | "fixnum-shift" ] + [ "math-internals" | "fixnum<" ] + [ "math-internals" | "fixnum<=" ] + [ "math-internals" | "fixnum>" ] + [ "math-internals" | "fixnum>=" ] + [ "math-internals" | "bignum=" ] + [ "math-internals" | "bignum+" ] + [ "math-internals" | "bignum-" ] + [ "math-internals" | "bignum*" ] + [ "math-internals" | "bignum/i" ] + [ "math-internals" | "bignum/f" ] + [ "math-internals" | "bignum-mod" ] + [ "math-internals" | "bignum/mod" ] + [ "math-internals" | "bignum-bitand" ] + [ "math-internals" | "bignum-bitor" ] + [ "math-internals" | "bignum-bitxor" ] + [ "math-internals" | "bignum-bitnot" ] + [ "math-internals" | "bignum-shift" ] + [ "math-internals" | "bignum<" ] + [ "math-internals" | "bignum<=" ] + [ "math-internals" | "bignum>" ] + [ "math-internals" | "bignum>=" ] + [ "math-internals" | "float=" ] + [ "math-internals" | "float+" ] + [ "math-internals" | "float-" ] + [ "math-internals" | "float*" ] + [ "math-internals" | "float/f" ] + [ "math-internals" | "float<" ] + [ "math-internals" | "float<=" ] + [ "math-internals" | "float>" ] + [ "math-internals" | "float>=" ] + [ "math-internals" | "facos" ] + [ "math-internals" | "fasin" ] + [ "math-internals" | "fatan" ] + [ "math-internals" | "fatan2" ] + [ "math-internals" | "fcos" ] + [ "math-internals" | "fexp" ] + [ "math-internals" | "fcosh" ] + [ "math-internals" | "flog" ] + [ "math-internals" | "fpow" ] + [ "math-internals" | "fsin" ] + [ "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" ] + [ "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" ] + [ "kernel" | "swap" ] + [ "kernel" | "over" ] + [ "kernel" | "pick" ] + [ "kernel" | ">r" ] + [ "kernel" | "r>" ] + [ "kernel" | "eq?" ] + [ "kernel" | "getenv" ] + [ "kernel" | "setenv" ] + [ "io-internals" | "open-file" ] + [ "files" | "stat" ] + [ "files" | "(directory)" ] + [ "kernel" | "garbage-collection" ] + [ "kernel" | "gc-time" ] + [ "kernel" | "save-image" ] + [ "kernel" | "datastack" ] + [ "kernel" | "callstack" ] + [ "kernel" | "set-datastack" ] + [ "kernel" | "set-callstack" ] + [ "kernel" | "exit*" ] + [ "io-internals" | "client-socket" ] + [ "io-internals" | "server-socket" ] + [ "io-internals" | "close-port" ] + [ "io-internals" | "add-accept-io-task" ] + [ "io-internals" | "accept-fd" ] + [ "io-internals" | "can-read-line?" ] + [ "io-internals" | "add-read-line-io-task" ] + [ "io-internals" | "read-line-fd-8" ] + [ "io-internals" | "can-read-count?" ] + [ "io-internals" | "add-read-count-io-task" ] + [ "io-internals" | "read-count-fd-8" ] + [ "io-internals" | "can-write?" ] + [ "io-internals" | "add-write-io-task" ] + [ "io-internals" | "write-fd-8" ] + [ "io-internals" | "add-copy-io-task" ] + [ "io-internals" | "pending-io-error" ] + [ "io-internals" | "next-io-task" ] + [ "kernel" | "room" ] + [ "kernel" | "os-env" ] + [ "kernel" | "millis" ] + [ "random" | "init-random" ] + [ "random" | "(random-int)" ] + [ "kernel" | "type" ] + [ "kernel" | "size" ] + [ "files" | "cwd" ] + [ "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" ] + [ "alien" | "dlopen" ] + [ "alien" | "dlsym" ] + [ "alien" | "dlsym-self" ] + [ "alien" | "dlclose" ] + [ "alien" | "" ] + [ "alien" | "" ] + [ "alien" | "alien-cell" ] + [ "alien" | "set-alien-cell" ] + [ "alien" | "alien-4" ] + [ "alien" | "set-alien-4" ] + [ "alien" | "alien-2" ] + [ "alien" | "set-alien-2" ] + [ "alien" | "alien-1" ] + [ "alien" | "set-alien-1" ] + [ "kernel" | "heap-stats" ] + [ "errors" | "throw" ] +] [ + unswons create swap succ [ f define ] keep +] each drop diff --git a/library/cli.factor b/library/cli.factor index 8e74bd5682..9c6cc95dcd 100644 --- a/library/cli.factor +++ b/library/cli.factor @@ -50,7 +50,7 @@ USE: words : run-user-init ( -- ) #! Run user init file if it exists "user-init" get [ - [ "~" get , "/" get , ".factor-" , "rc" , ] make-string + [ "~" get , "/" , ".factor-" , "rc" , ] make-string ?run-file ] when ; diff --git a/library/combinators.factor b/library/combinators.factor index 290e00d096..197fc7c0eb 100644 --- a/library/combinators.factor +++ b/library/combinators.factor @@ -51,6 +51,7 @@ 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: #! diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index cec3613168..35aa35cbd0 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -28,6 +28,7 @@ IN: alien USE: compiler USE: errors +USE: generic USE: inference USE: interpreter USE: kernel @@ -37,6 +38,9 @@ USE: namespaces USE: parser USE: words +BUILTIN: dll 15 +BUILTIN: alien 16 + : library ( name -- handle ) "libraries" get [ dup get dup dll? [ diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index a307262a4a..f9b2b05c7e 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -99,7 +99,7 @@ SYMBOL: #target ( part of jump table ) gensym dup t "label" set-word-property ; : label? ( obj -- ? ) - dup word ? [ "label" word-property ] [ drop f ] ifte ; + dup word? [ "label" word-property ] [ drop f ] ifte ; : label, ( label -- ) #label swons , ; diff --git a/library/cons.factor b/library/cons.factor index a809ec06fe..0a9befa4e7 100644 --- a/library/cons.factor +++ b/library/cons.factor @@ -26,8 +26,15 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: lists +USE: generic USE: kernel +! This file contains vital list-related words that everything +! else depends on, and is loaded early in bootstrap. +! lists.factor has everything else. + +BUILTIN: cons 2 + : 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. @@ -50,3 +57,53 @@ USE: kernel : 2cdr ( cons cons -- car car ) swap cdr swap cdr ; + +: last* ( list -- last ) + #! Last cons of a list. + dup cdr cons? [ cdr last* ] when ; + +: last ( list -- last ) + #! Last element of a list. + last* car ; + +: tail ( list -- tail ) + #! Return the cdr of the last cons cell, or f. + dup [ last* cdr ] when ; + +: list? ( list -- ? ) + #! Proper list test. A proper list is either f, or a cons + #! cell whose cdr is a proper list. + dup cons? [ tail ] when not ; + +: all? ( list pred -- ? ) + #! Push if the predicate returns true for each element of + #! the list. + over [ + dup >r swap uncons >r swap call [ + r> r> all? + ] [ + r> drop r> drop f + ] ifte + ] [ + 2drop t + ] ifte ; inline + +: (each) ( list quot -- list quot ) + >r uncons r> tuck 2slip ; inline + +: each ( list quot -- ) + #! Push each element of a proper list in turn, and apply a + #! quotation with effect ( X -- ) to each element. + over [ (each) each ] [ 2drop ] ifte ; inline + +: subset ( list quot -- list ) + #! Applies a quotation with effect ( X -- ? ) to each + #! element of a list; all elements for which the quotation + #! returned a value other than f are collected in a new + #! list. + over [ + over car >r (each) + rot >r subset r> [ r> swons ] [ r> drop ] ifte + ] [ + drop + ] ifte ; inline diff --git a/library/errors.factor b/library/errors.factor index 72f40d86e0..53eded4680 100644 --- a/library/errors.factor +++ b/library/errors.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: kernel +DEFER: callcc1 + IN: errors USE: kernel USE: lists diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 6ba89be528..5c97b81423 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -55,6 +55,9 @@ USE: vectors ! - metaclass: a metaclass is a symbol with a handful of word ! properties: "define-method" "builtin-types" +: undefined-method + "No applicable method." throw ; + : metaclass ( class -- metaclass ) "metaclass" word-property ; diff --git a/library/generic/traits.factor b/library/generic/traits.factor index a02943a120..518dc02db5 100644 --- a/library/generic/traits.factor +++ b/library/generic/traits.factor @@ -68,9 +68,6 @@ SYMBOL: delegate : init-traits-map ( word -- ) "traits-map" set-word-property ; -: undefined-method - "No applicable method." throw ; - : traits-dispatch ( selector traits -- traits quot ) #! Look up the method with the traits object on the stack. #! Returns the traits to call the method on; either the diff --git a/library/hashtables.factor b/library/hashtables.factor index 63238063be..db3cd9316a 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -93,3 +93,27 @@ PREDICATE: vector hashtable ( obj -- ? ) : alist>hash ( alist -- hash ) 37 swap [ unswons pick set-hash ] each ; + +: hash-map ( hash code -- hash ) + #! Apply the code to each key/value pair of the hashtable, + #! collecting return values in a new hashtable. + >r hash>alist r> map alist>hash ; + +! In case I break hashing: + +! : hash ( key table -- value ) +! hash>alist assoc ; +! +! : set-hash ( value key table -- ) +! dup vector-length [ +! ( value key table index ) +! >r 3dup r> +! ( value key table value key table index ) +! [ +! swap vector-nth +! ( value key table value key alist ) +! set-assoc +! ] keep +! ( value key table new-assoc index ) +! pick set-vector-nth +! ] times* 3drop ; diff --git a/library/io/files.factor b/library/io/files.factor index ae97179635..9cd1028932 100644 --- a/library/io/files.factor +++ b/library/io/files.factor @@ -42,7 +42,7 @@ USE: strings : directory ( dir -- list ) #! List a directory. - (directory) str-sort ; + (directory) [ str-lexi> ] sort ; : file-length ( file -- length ) stat dup [ cdr cdr car ] when ; diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor index f80d9b4d53..0496ac2793 100644 --- a/library/io/io-internals.factor +++ b/library/io/io-internals.factor @@ -26,11 +26,14 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: io-internals +USE: generic USE: kernel USE: namespaces USE: strings USE: threads +BUILTIN: port 14 + : stdin 0 getenv ; : stdout 1 getenv ; diff --git a/library/io/stream.factor b/library/io/stream.factor index 0c56029145..15b5b69a52 100644 --- a/library/io/stream.factor +++ b/library/io/stream.factor @@ -42,12 +42,12 @@ GENERIC: fclose ( stream -- ) : fread1 ( stream -- string ) 1 swap fread# dup f-or-"" [ 0 swap str-nth ] unless ; -: fprint ( string stream -- ) - tuck fwrite "\n" over fwrite fauto-flush ; - : fwrite ( string stream -- ) f swap fwrite-attr ; +: fprint ( string stream -- ) + tuck fwrite "\n" over fwrite fauto-flush ; + TRAITS: string-output-stream M: string-output-stream fwrite-attr ( string style stream -- ) diff --git a/library/kernel.factor b/library/kernel.factor index 0f94ef4aa5..bd9e2aeae4 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -25,10 +25,19 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +IN: syntax +USE: generic +BUILTIN: f 6 FORGET: f? +BUILTIN: t 7 FORGET: t? + IN: vectors DEFER: vector= DEFER: vector-hashcode +IN: lists +DEFER: cons= +DEFER: cons-hashcode + IN: kernel USE: lists USE: math @@ -108,3 +117,7 @@ IN: kernel : set-boot ( quot -- ) #! Set the boot quotation. 8 setenv ; + +: num-types ( -- n ) + #! One more than the maximum value from type primitive. + 17 ; diff --git a/library/lists.factor b/library/lists.factor index f01f6adf62..83c80d1547 100644 --- a/library/lists.factor +++ b/library/lists.factor @@ -56,30 +56,6 @@ USE: vectors #! Test if a list contains an element. [ over = ] some? >boolean nip ; -: nth ( n list -- list[n] ) - #! nth element of a proper list. - #! Supplying n <= 0 pushes the first element of the list. - #! Supplying an argument beyond the end of the list raises - #! an error. - swap [ cdr ] times car ; - -: last* ( list -- last ) - #! Last cons of a list. - dup cdr cons? [ cdr last* ] when ; - -: last ( list -- last ) - #! Last element of a list. - last* car ; - -: tail ( list -- tail ) - #! Return the cdr of the last cons cell, or f. - dup [ last* cdr ] when ; - -: list? ( list -- ? ) - #! Proper list test. A proper list is either f, or a cons - #! cell whose cdr is a proper list. - dup cons? [ tail ] when not ; - : partition-add ( obj ? ret1 ret2 -- ret1 ret2 ) rot [ swapd cons ] [ >r cons r> ] ifte ; @@ -109,10 +85,6 @@ USE: vectors drop ] ifte ; inline -: num-sort ( list -- sorted ) - #! Sorts the list into ascending numerical order. - [ > ] sort ; - ! Redefined below DEFER: tree-contains? @@ -140,14 +112,6 @@ DEFER: tree-contains? #! list. 2dup contains? [ nip ] [ cons ] ifte ; -: (each) ( list quot -- list quot ) - >r uncons r> tuck 2slip ; inline - -: each ( list quot -- ) - #! Push each element of a proper list in turn, and apply a - #! quotation with effect ( X -- ) to each element. - over [ (each) each ] [ 2drop ] ifte ; inline - : reverse ( list -- list ) [ ] swap [ swons ] each ; @@ -157,18 +121,6 @@ DEFER: tree-contains? #! ( X -- Y ) to each element into a new list. over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline -: subset ( list quot -- list ) - #! Applies a quotation with effect ( X -- ? ) to each - #! element of a list; all elements for which the quotation - #! returned a value other than f are collected in a new - #! list. - over [ - over car >r (each) - rot >r subset r> [ r> swons ] [ r> drop ] ifte - ] [ - drop - ] ifte ; inline - : remove ( obj list -- list ) #! Remove all occurrences of the object from the list. [ dupd = not ] subset nip ; @@ -182,19 +134,6 @@ DEFER: tree-contains? uncons prune 2dup contains? [ nip ] [ cons ] ifte ] when ; -: all? ( list pred -- ? ) - #! Push if the predicate returns true for each element of - #! the list. - over [ - dup >r swap uncons >r swap call [ - r> r> all? - ] [ - r> drop r> drop f - ] ifte - ] [ - 2drop t - ] ifte ; inline - : all=? ( list -- ? ) #! Check if all elements of a list are equal. dup [ uncons [ over = ] all? nip ] [ drop t ] ifte ; @@ -241,15 +180,6 @@ DEFER: tree-contains? : cons-hashcode ( cons -- hash ) 4 (cons-hashcode) ; -: list>vector ( list -- vector ) - dup length swap [ over vector-push ] each ; - -: stack>list ( vector -- list ) - [ ] swap [ swons ] vector-each ; - -: vector>list ( vector -- list ) - stack>list reverse ; - : project ( n quot -- list ) #! Execute the quotation n times, passing the loop counter #! the quotation as it ranges from 0..n-1. Collect results diff --git a/library/math/generic.factor b/library/math/generic.factor index 3b88e1da4b..82c7aaac30 100644 --- a/library/math/generic.factor +++ b/library/math/generic.factor @@ -32,7 +32,27 @@ USE: kernel USE: vectors USE: words +BUILTIN: fixnum 0 +BUILTIN: ratio 4 +BUILTIN: complex 5 +BUILTIN: bignum 9 +BUILTIN: float 10 + DEFER: number= +DEFER: mod +DEFER: abs +DEFER: < +DEFER: <= +DEFER: > +DEFER: >= +DEFER: neg +DEFER: /i +DEFER: * +DEFER: + +DEFER: - +DEFER: / +DEFER: /f +DEFER: sq : (gcd) ( x y -- z ) dup 0 = [ drop ] [ tuck mod (gcd) ] ifte ; : gcd ( x y -- z ) abs swap abs 2dup < [ swap ] when (gcd) ; diff --git a/library/namespaces.factor b/library/namespaces.factor index 0d7ce7c6a9..79160b77b5 100644 --- a/library/namespaces.factor +++ b/library/namespaces.factor @@ -70,7 +70,7 @@ USE: vectors : set-global ( g -- ) 4 setenv ; : init-namespaces ( -- ) - global >n global "global" set ; + global >n ; : namespace-buckets 23 ; diff --git a/library/sdl/hsv.factor b/library/sdl/hsv.factor index 5163fb4cfd..79c1843d98 100644 --- a/library/sdl/hsv.factor +++ b/library/sdl/hsv.factor @@ -11,24 +11,25 @@ USE: kernel USE: lists USE: math USE: namespaces +USE: vectors : f_ ( h s v i -- f ) >r swap rot >r 2dup r> 6 * r> - ; : p ( v s x -- v p x ) >r dupd neg succ * r> ; : q ( v s f -- q ) * neg succ * ; : t_ ( v s f -- t_ ) neg succ * neg succ * ; -: mod-cond ( p list -- ) - #! Call p mod q'th entry of the list of quotations, where - #! q is the length of the list. The value q remains on the +: mod-cond ( p vector -- ) + #! Call p mod q'th entry of the vector of quotations, where + #! q is the length of the vector. The value q remains on the #! stack. - [ dupd length mod ] keep nth call ; + [ dupd length mod ] keep vector-nth call ; : hsv>rgb ( h s v -- r g b ) - pick 6 * >fixnum [ + pick 6 * >fixnum { [ f_ t_ p swap ( v p t ) ] [ f_ q p -rot ( q v p ) ] [ f_ t_ p swapd ( p v t ) ] [ f_ q p rot ( p q v ) ] [ f_ t_ p swap rot ( t p v ) ] [ f_ q p ( v p q ) ] - ] mod-cond ; + } mod-cond ; diff --git a/library/strings.factor b/library/strings.factor index 683f3630ea..901145131f 100644 --- a/library/strings.factor +++ b/library/strings.factor @@ -26,10 +26,14 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: strings +USE: generic USE: kernel USE: lists USE: math +BUILTIN: string 12 +BUILTIN: sbuf 13 + : f-or-"" ( obj -- ? ) dup not swap "" = or ; @@ -132,11 +136,6 @@ USE: math -rot 2dup >r >r >r str-nth r> call r> r> ] times* 2drop ; inline -: str-sort ( list -- sorted ) - #! Sorts the list into ascending lexicographical string - #! order. - [ str-lexi> ] sort ; - : blank? ( ch -- ? ) " \t\n\r" str-contains? ; : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; diff --git a/library/syntax/parse-syntax.factor b/library/syntax/parse-syntax.factor index 737b2cec12..b17e74006e 100644 --- a/library/syntax/parse-syntax.factor +++ b/library/syntax/parse-syntax.factor @@ -25,7 +25,9 @@ ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -IN: parser +! Bootstrapping trick; see doc/bootstrap.txt. +IN: !syntax +USE: syntax USE: errors USE: hashtables @@ -33,82 +35,17 @@ USE: kernel USE: lists USE: math USE: namespaces +USE: parser USE: strings USE: words USE: vectors USE: unparser -! Colon defs -: CREATE ( -- word ) - scan "in" get create dup set-word - dup f "documentation" set-word-property - dup f "stack-effect" set-word-property - dup "line-number" get "line" set-word-property - dup "col" get "col" set-word-property - dup "file" get "file" set-word-property ; - -! \x -: unicode-escape>ch ( -- esc ) - #! Read \u.... - next-ch digit> 16 * - next-ch digit> + 16 * - next-ch digit> + 16 * - next-ch digit> + ; - -: ascii-escape>ch ( ch -- esc ) - [ - [ CHAR: e | CHAR: \e ] - [ CHAR: n | CHAR: \n ] - [ CHAR: r | CHAR: \r ] - [ CHAR: t | CHAR: \t ] - [ CHAR: s | CHAR: \s ] - [ CHAR: \s | CHAR: \s ] - [ CHAR: 0 | CHAR: \0 ] - [ CHAR: \\ | CHAR: \\ ] - [ CHAR: \" | CHAR: \" ] - ] assoc ; - -: escape ( ch -- esc ) - dup CHAR: u = [ - drop unicode-escape>ch - ] [ - ascii-escape>ch - ] ifte ; - -: parse-escape ( -- ) - next-ch escape dup [ drop "Bad escape" throw ] unless ; - -: parse-ch ( ch -- ch ) - dup CHAR: \\ = [ drop parse-escape ] when ; - -: doc-comment-here? ( parsed -- ? ) - not "in-definition" get and ; - -: parsed-stack-effect ( parsed str -- parsed ) - over doc-comment-here? [ - word stack-effect [ - drop - ] [ - word swap "stack-effect" set-word-property - ] ifte - ] [ - drop - ] ifte ; - -: documentation+ ( word str -- ) - over "documentation" word-property [ - swap "\n" swap cat3 - ] when* - "documentation" set-word-property ; - -: parsed-documentation ( parsed str -- parsed ) - over doc-comment-here? [ - word swap documentation+ - ] [ - drop - ] ifte ; - -IN: syntax +: parsing ( -- ) + #! Mark the most recently defined word to execute at parse + #! time, rather than run time. The word can use 'scan' to + #! read ahead in the input stream. + word t "parsing" set-word-property ; parsing : inline ( -- ) #! Mark the last word to be inlined. diff --git a/library/syntax/parser.factor b/library/syntax/parser.factor index eec6b8364a..9b81047823 100644 --- a/library/syntax/parser.factor +++ b/library/syntax/parser.factor @@ -79,7 +79,7 @@ USE: unparser ] ifte ] [ r> drop nip str-length - ] ifte ; + ] ifte ; inline : skip-blank ( n line -- n ) [ blank? not ] skip ; @@ -179,15 +179,71 @@ USE: unparser : next-word-ch ( -- ch ) "col" get "line" get skip-blank "col" set next-ch ; -IN: syntax +: CREATE ( -- word ) + scan "in" get create dup set-word + dup f "documentation" set-word-property + dup f "stack-effect" set-word-property + dup "line-number" get "line" set-word-property + dup "col" get "col" set-word-property + dup "file" get "file" set-word-property ; -: parsing ( -- ) - #! Mark the most recently defined word to execute at parse - #! time, rather than run time. The word can use 'scan' to - #! read ahead in the input stream. - word t "parsing" set-word-property ; +! \x +: unicode-escape>ch ( -- esc ) + #! Read \u.... + next-ch digit> 16 * + next-ch digit> + 16 * + next-ch digit> + 16 * + next-ch digit> + ; -! Once this file has loaded, we can use 'parsing' normally. -! This hack is needed because in Java Factor, 'parsing' is -! not parsing, but in CFactor, it is. -\ parsing t "parsing" set-word-property +: ascii-escape>ch ( ch -- esc ) + [ + [ CHAR: e | CHAR: \e ] + [ CHAR: n | CHAR: \n ] + [ CHAR: r | CHAR: \r ] + [ CHAR: t | CHAR: \t ] + [ CHAR: s | CHAR: \s ] + [ CHAR: \s | CHAR: \s ] + [ CHAR: 0 | CHAR: \0 ] + [ CHAR: \\ | CHAR: \\ ] + [ CHAR: \" | CHAR: \" ] + ] assoc ; + +: escape ( ch -- esc ) + dup CHAR: u = [ + drop unicode-escape>ch + ] [ + ascii-escape>ch + ] ifte ; + +: parse-escape ( -- ) + next-ch escape dup [ drop "Bad escape" throw ] unless ; + +: parse-ch ( ch -- ch ) + dup CHAR: \\ = [ drop parse-escape ] when ; + +: doc-comment-here? ( parsed -- ? ) + not "in-definition" get and ; + +: parsed-stack-effect ( parsed str -- parsed ) + over doc-comment-here? [ + word stack-effect [ + drop + ] [ + word swap "stack-effect" set-word-property + ] ifte + ] [ + drop + ] ifte ; + +: documentation+ ( word str -- ) + over "documentation" word-property [ + swap "\n" swap cat3 + ] when* + "documentation" set-word-property ; + +: parsed-documentation ( parsed str -- parsed ) + over doc-comment-here? [ + word swap documentation+ + ] [ + drop + ] ifte ; diff --git a/library/syntax/unparser.factor b/library/syntax/unparser.factor index dfe891c5f2..e89fa25c93 100644 --- a/library/syntax/unparser.factor +++ b/library/syntax/unparser.factor @@ -37,6 +37,34 @@ USE: stdio USE: strings USE: words +: type-name ( n -- str ) + [ + [ 0 | "fixnum" ] + [ 1 | "word" ] + [ 2 | "cons" ] + [ 3 | "object" ] + [ 4 | "ratio" ] + [ 5 | "complex" ] + [ 6 | "f" ] + [ 7 | "t" ] + [ 8 | "array" ] + [ 9 | "bignum" ] + [ 10 | "float" ] + [ 11 | "vector" ] + [ 12 | "string" ] + [ 13 | "sbuf" ] + [ 14 | "port" ] + [ 15 | "dll" ] + [ 16 | "alien" ] + ! These values are only used by the kernel for error + ! reporting. + [ 100 | "fixnum/bignum" ] + [ 101 | "fixnum/bignum/ratio" ] + [ 102 | "fixnum/bignum/ratio/float" ] + [ 103 | "fixnum/bignum/ratio/float/complex" ] + [ 104 | "fixnum/string" ] + ] assoc ; + GENERIC: unparse ( obj -- str ) M: object unparse ( obj -- str ) diff --git a/library/test/benchmark/sort.factor b/library/test/benchmark/sort.factor index 79b743ec72..264583f1b3 100644 --- a/library/test/benchmark/sort.factor +++ b/library/test/benchmark/sort.factor @@ -5,4 +5,4 @@ USE: math USE: random USE: test -[ ] [ [ 100000 [ 0 10000 random-int , ] times ] make-list num-sort drop ] unit-test +[ ] [ [ 100000 [ 0 10000 random-int , ] times ] make-list [ > ] sort drop ] unit-test diff --git a/library/test/inspector.factor b/library/test/inspector.factor index 63983a2cf5..256538ba33 100644 --- a/library/test/inspector.factor +++ b/library/test/inspector.factor @@ -6,4 +6,4 @@ USE: words "httpd" apropos. "car" usages. global describe -"vocabularies" get describe +vocabularies get describe diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index de6815b304..d5a1dca4ad 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -17,10 +17,10 @@ USE: strings [ [ 43 "a" [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test -[ "fdsfs" num-sort ] unit-test-fails -[ [ ] ] [ [ ] num-sort ] unit-test +[ "fdsfs" [ > ] sort ] unit-test-fails +[ [ ] ] [ [ ] [ > ] sort ] unit-test [ [ "2 + 2" ] ] [ [ "2 + 2" ] [ str-lexi> ] sort ] unit-test -[ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] num-sort ] unit-test +[ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] [ > ] sort ] unit-test [ f ] [ [ { } { } "Hello" ] all=? ] unit-test [ f ] [ [ { 2 } { } { } ] all=? ] unit-test diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor index c6f9f43b30..cac9c7447a 100644 --- a/library/test/lists/lists.factor +++ b/library/test/lists/lists.factor @@ -17,10 +17,6 @@ USE: strings [ t ] [ 1 [ 1 2 ] contains? >boolean ] unit-test [ t ] [ 2 [ 1 2 ] contains? >boolean ] unit-test -[ 1 ] [ -1 [ 1 2 ] nth ] unit-test -[ 1 ] [ 0 [ 1 2 ] nth ] unit-test -[ 2 ] [ 1 [ 1 2 ] nth ] unit-test - [ [ 3 ] ] [ [ 3 ] last* ] unit-test [ [ 3 ] ] [ [ 1 2 3 ] last* ] unit-test [ [ 3 | 4 ] ] [ [ 1 2 3 | 4 ] last* ] unit-test diff --git a/library/test/namespaces.factor b/library/test/namespaces.factor index 2a95b8b40a..08926e7be7 100644 --- a/library/test/namespaces.factor +++ b/library/test/namespaces.factor @@ -29,7 +29,7 @@ unit-test [ t ] [ \ test-word - global [ [ "vocabularies" "test" "test-word" ] object-path ] bind + global [ [ vocabularies "test" "test-word" ] object-path ] bind = ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 480aaaa601..eeb93eea0d 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -13,6 +13,7 @@ USE: prettyprint USE: stdio USE: strings USE: words +USE: vectors USE: unparser : assert ( t -- ) @@ -62,7 +63,7 @@ USE: unparser : all-tests ( -- ) "Running Factor test suite..." print - "vocabularies" get [ f "scratchpad" set ] bind + vocabularies get [ "scratchpad" off ] bind [ "lists/cons" "lists/lists" diff --git a/library/test/words.factor b/library/test/words.factor index 92a159aed7..e8198c12e1 100644 --- a/library/test/words.factor +++ b/library/test/words.factor @@ -36,8 +36,6 @@ DEFER: plist-test ] unit-test [ - "vocabularies" set - [ t ] [ \ car "car" [ "lists" ] search = ] unit-test "test-scope" "scratchpad" create drop diff --git a/library/types.factor b/library/types.factor deleted file mode 100644 index 12384f40a1..0000000000 --- a/library/types.factor +++ /dev/null @@ -1,81 +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. - -USE: kernel -USE: math -USE: generic - -IN: vectors SYMBOL: vector -IN: math BUILTIN: fixnum 0 -IN: words BUILTIN: word 1 -IN: lists BUILTIN: cons 2 -IN: math BUILTIN: ratio 4 -IN: math BUILTIN: complex 5 -IN: syntax BUILTIN: f 6 FORGET: f? -IN: syntax BUILTIN: t 7 FORGET: t? -IN: math BUILTIN: bignum 9 -IN: math BUILTIN: float 10 -IN: vectors BUILTIN: vector 11 -IN: strings BUILTIN: string 12 -IN: strings BUILTIN: sbuf 13 -IN: io-internals BUILTIN: port 14 -IN: alien BUILTIN: dll 15 -IN: alien BUILTIN: alien 16 - -IN: kernel - -: type-name ( n -- str ) - [ - [ 0 | "fixnum" ] - [ 1 | "word" ] - [ 2 | "cons" ] - [ 3 | "object" ] - [ 4 | "ratio" ] - [ 5 | "complex" ] - [ 6 | "f" ] - [ 7 | "t" ] - [ 8 | "array" ] - [ 9 | "bignum" ] - [ 10 | "float" ] - [ 11 | "vector" ] - [ 12 | "string" ] - [ 13 | "sbuf" ] - [ 14 | "port" ] - [ 15 | "dll" ] - [ 16 | "alien" ] - ! These values are only used by the kernel for error - ! reporting. - [ 100 | "fixnum/bignum" ] - [ 101 | "fixnum/bignum/ratio" ] - [ 102 | "fixnum/bignum/ratio/float" ] - [ 103 | "fixnum/bignum/ratio/float/complex" ] - [ 104 | "fixnum/string" ] - ] assoc ; - -: num-types ( -- n ) - #! One more than the maximum value from type primitive. - 17 ; diff --git a/library/vectors.factor b/library/vectors.factor index d938d12537..3791ef25d0 100644 --- a/library/vectors.factor +++ b/library/vectors.factor @@ -26,10 +26,13 @@ ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. IN: vectors +USE: generic USE: kernel USE: lists USE: math +BUILTIN: vector 11 + : empty-vector ( len -- vec ) #! Creates a vector with 'len' elements set to f. Unlike #! , which gives an empty vector with a certain @@ -105,6 +108,15 @@ USE: math #! Shallow copy of a vector. [ ] vector-map ; +: list>vector ( list -- vector ) + dup length swap [ over vector-push ] each ; + +: stack>list ( vector -- list ) + [ ] swap [ swons ] vector-each ; + +: vector>list ( vector -- list ) + stack>list reverse ; + : vector-length= ( vec vec -- ? ) vector-length swap vector-length number= ; diff --git a/library/vocabularies.factor b/library/vocabularies.factor index b0b184d10f..405d338cbb 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -30,6 +30,31 @@ USE: hashtables USE: kernel USE: lists USE: namespaces +USE: strings + +: word ( -- word ) global [ "last-word" get ] bind ; +: set-word ( word -- ) global [ "last-word" set ] bind ; + +: vocabs ( -- list ) + #! Push a list of vocabularies. + vocabularies get hash-keys [ str-lexi> ] sort ; + +: vocab ( name -- vocab ) + #! Get a vocabulary. + vocabularies get hash ; + +: word-sort ( list -- list ) + #! Sort a list of words by name. + [ swap word-name swap word-name str-lexi> ] sort ; + +: words ( vocab -- list ) + #! Push a list of all words in a vocabulary. + #! Filter empty slots. + vocab hash-values [ ] subset word-sort ; + +: each-word ( quot -- ) + #! Apply a quotation to each word in the image. + vocabs [ words [ swap dup >r call r> ] each ] each drop ; : (search) ( name vocab -- word ) vocab dup [ hash ] [ 2drop f ] ifte ; @@ -55,12 +80,10 @@ USE: namespaces : reveal ( word -- ) #! Add a new word to its vocabulary. - global [ - "vocabularies" get [ - dup word-vocabulary - over word-name - 2list set-object-path - ] bind + vocabularies get [ + dup word-vocabulary + over word-name + 2list set-object-path ] bind ; : create ( name vocab -- word ) @@ -72,3 +95,46 @@ USE: namespaces : forget ( word -- ) #! Remove a word definition. dup word-vocabulary vocab [ word-name off ] bind ; + +: init-search-path ( -- ) + ! For files + "scratchpad" "file-in" set + [ "builtins" "syntax" "scratchpad" ] "file-use" set + ! For interactive + "scratchpad" "in" set + [ + "user" + "arithmetic" + "builtins" + "compiler" + "debugger" + "errors" + "files" + "hashtables" + "inference" + "inferior" + "interpreter" + "inspector" + "jedit" + "kernel" + "listener" + "lists" + "math" + "namespaces" + "parser" + "prettyprint" + "processes" + "profiler" + "stack" + "streams" + "stdio" + "strings" + "syntax" + "test" + "threads" + "unparser" + "vectors" + "vocabularies" + "words" + "scratchpad" + ] "use" set ; diff --git a/library/words.factor b/library/words.factor index f834a23f64..c5c9317506 100644 --- a/library/words.factor +++ b/library/words.factor @@ -34,6 +34,10 @@ USE: math USE: namespaces USE: strings +BUILTIN: word 1 + +SYMBOL: vocabularies + : word-property ( word pname -- pvalue ) swap word-plist assoc ; @@ -47,19 +51,11 @@ PREDICATE: word primitive ( obj -- ? ) word-primitive 2 > ; PREDICATE: word symbol ( obj -- ? ) word-primitive 2 = ; PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ; -: word ( -- word ) global [ "last-word" get ] bind ; -: set-word ( word -- ) global [ "last-word" set ] bind ; - -: (define) ( word primitive parameter -- ) - #! Define a word in the current Factor instance. +: define ( word primitive parameter -- ) pick set-word-parameter over set-word-primitive f "parsing" set-word-property ; -: define ( word primitive parameter -- ) - #! The define-hook is set by the image bootstrapping code. - "define-hook" get [ call ] [ (define) ] ifte* ; - : define-compound ( word def -- ) 1 swap define ; : define-symbol ( word -- ) 2 over define ; @@ -68,66 +64,7 @@ PREDICATE: word undefined ( obj -- ? ) word-primitive 0 = ; : stack-effect ( word -- str ) "stack-effect" word-property ; : documentation ( word -- str ) "documentation" word-property ; -: vocabs ( -- list ) - #! Push a list of vocabularies. - global [ "vocabularies" get hash-keys str-sort ] bind ; - -: vocab ( name -- vocab ) - #! Get a vocabulary. - global [ "vocabularies" get hash ] bind ; - -: word-sort ( list -- list ) - #! Sort a list of words by name. - [ swap word-name swap word-name str-lexi> ] sort ; - -: words ( vocab -- list ) - #! Push a list of all words in a vocabulary. - #! Filter empty slots. - vocab hash-values [ ] subset word-sort ; - -: each-word ( quot -- ) - #! Apply a quotation to each word in the image. - vocabs [ words [ swap dup >r call r> ] each ] each drop ; - -: init-search-path ( -- ) - ! For files - "scratchpad" "file-in" set - [ "builtins" "syntax" "scratchpad" ] "file-use" set - ! For interactive - "scratchpad" "in" set - [ - "user" - "arithmetic" - "builtins" - "compiler" - "debugger" - "errors" - "files" - "hashtables" - "inference" - "inferior" - "interpreter" - "inspector" - "jedit" - "kernel" - "listener" - "lists" - "math" - "namespaces" - "parser" - "prettyprint" - "processes" - "profiler" - "stack" - "streams" - "stdio" - "strings" - "syntax" - "test" - "threads" - "unparser" - "vectors" - "vocabularies" - "words" - "scratchpad" - ] "use" set ; +: word-clone ( word -- word ) + dup word-primitive + over word-parameter + rot word-plist ; diff --git a/native/types.h b/native/types.h index 6bc956bc8a..2bbf947eb7 100644 --- a/native/types.h +++ b/native/types.h @@ -51,6 +51,8 @@ INLINE CELL tag_header(CELL cell) return RETAG(cell << TAG_BITS,HEADER_TYPE); } +#define HEADER_DEBUG + INLINE CELL untag_header(CELL cell) { CELL type = cell >> TAG_BITS; @@ -77,6 +79,10 @@ INLINE void type_check(CELL type, CELL tagged) { if(type < HEADER_TYPE) { +#ifdef HEADER_DEBUG + if(type == WORD_TYPE && object_type(tagged) != WORD_TYPE) + critical_error("word header check",tagged); +#endif if(TAG(tagged) == type) return; }