Merge branch 'master' of git://factorcode.org/git/factor

Makefile

@@ -3,7 +3,7 @@ AR = ar
 LD = ld
 
 EXECUTABLE = factor
-VERSION = 0.91
+VERSION = 0.92
 
 IMAGE = factor.image
 BUNDLE = Factor.app

core/bootstrap/image/image.factor

@@ -8,7 +8,7 @@ grouping growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger
 quotations.private sequences.private combinators
-io.encodings.binary math.order accessors ;
+io.encodings.binary math.order math.private accessors slots.private ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -75,7 +75,7 @@ SYMBOL: objects
 
 : data-base 1024 ; inline
 
-: userenv-size 64 ; inline
+: userenv-size 70 ; inline
 
 : header-size 10 ; inline
 
@@ -118,6 +118,29 @@ SYMBOL: jit-dispatch
 SYMBOL: jit-epilog
 SYMBOL: jit-return
 SYMBOL: jit-profiling
+SYMBOL: jit-tag
+SYMBOL: jit-tag-word
+SYMBOL: jit-eq?
+SYMBOL: jit-eq?-word
+SYMBOL: jit-slot
+SYMBOL: jit-slot-word
+SYMBOL: jit-declare-word
+SYMBOL: jit-drop
+SYMBOL: jit-drop-word
+SYMBOL: jit-dup
+SYMBOL: jit-dup-word
+SYMBOL: jit->r
+SYMBOL: jit->r-word
+SYMBOL: jit-r>
+SYMBOL: jit-r>-word
+SYMBOL: jit-swap
+SYMBOL: jit-swap-word
+SYMBOL: jit-over
+SYMBOL: jit-over-word
+SYMBOL: jit-fixnum-fast
+SYMBOL: jit-fixnum-fast-word
+SYMBOL: jit-fixnum>=
+SYMBOL: jit-fixnum>=-word
 
 ! Default definition for undefined words
 SYMBOL: undefined-quot
@@ -140,7 +163,30 @@ SYMBOL: undefined-quot
         { jit-epilog 33 }
         { jit-return 34 }
         { jit-profiling 35 }
-        { undefined-quot 37 }
+        { jit-tag 36 }
+        { jit-tag-word 37 }
+        { jit-eq? 38 }
+        { jit-eq?-word 39 }
+        { jit-slot 40 }
+        { jit-slot-word 41 }
+        { jit-declare-word 42 }
+        { jit-drop 43 }
+        { jit-drop-word 44 }
+        { jit-dup 45 }
+        { jit-dup-word 46 }
+        { jit->r 47 }
+        { jit->r-word 48 }
+        { jit-r> 49 }
+        { jit-r>-word 50 }
+        { jit-swap 51 }
+        { jit-swap-word 52 }
+        { jit-over 53 }
+        { jit-over-word 54 }
+        { jit-fixnum-fast 55 }
+        { jit-fixnum-fast-word 56 }
+        { jit-fixnum>= 57 }
+        { jit-fixnum>=-word 58 }
+        { undefined-quot 60 }
     } at header-size + ;
 
 : emit ( cell -- ) image get push ;
@@ -414,6 +460,18 @@ M: quotation '
     \ if jit-if-word set
     \ dispatch jit-dispatch-word set
     \ do-primitive jit-primitive-word set
+    \ tag jit-tag-word set
+    \ eq? jit-eq?-word set
+    \ slot jit-slot-word set
+    \ declare jit-declare-word set
+    \ drop jit-drop-word set
+    \ dup jit-dup-word set
+    \ >r jit->r-word set
+    \ r> jit-r>-word set
+    \ swap jit-swap-word set
+    \ over jit-over-word set
+    \ fixnum-fast jit-fixnum-fast-word set
+    \ fixnum>= jit-fixnum>=-word set
     [ undefined ] undefined-quot set
     {
         jit-code-format
@@ -430,6 +488,29 @@ M: quotation '
         jit-epilog
         jit-return
         jit-profiling
+        jit-tag
+        jit-tag-word
+        jit-eq?
+        jit-eq?-word
+        jit-slot
+        jit-slot-word
+        jit-declare-word
+        jit-drop
+        jit-drop-word
+        jit-dup
+        jit-dup-word
+        jit->r
+        jit->r-word
+        jit-r>
+        jit-r>-word
+        jit-swap
+        jit-swap-word
+        jit-over
+        jit-over-word
+        jit-fixnum-fast
+        jit-fixnum-fast-word
+        jit-fixnum>=
+        jit-fixnum>=-word
         undefined-quot
     } [ emit-userenv ] each ;
 

core/classes/algebra/algebra.factor

@@ -224,3 +224,6 @@ M: anonymous-union (flatten-class)
         dup num-tags get >=
         [ drop \ hi-tag tag-number ] when
     ] map prune ;
+
+: class-tag ( class -- tag/f )
+    class-tags dup length 1 = [ first ] [ drop f ] if ;

core/compiler/tests/reload.factor

@@ -1,6 +1,6 @@
 IN: compiler.tests
 USE: vocabs.loader
 
-"parser" reload
+! "parser" reload
-"sequences" reload
+! "sequences" reload
-"kernel" reload
+! "kernel" reload

core/cpu/x86/32/bootstrap.factor

@@ -11,6 +11,7 @@ IN: bootstrap.x86
 : temp-reg ( -- reg ) EBX ;
 : stack-reg ( -- reg ) ESP ;
 : ds-reg ( -- reg ) ESI ;
+: rs-reg ( -- reg ) EDI ;
 : fixnum>slot@ ( -- ) arg0 1 SAR ;
 : rex-length ( -- n ) 0 ;
 

core/cpu/x86/64/bootstrap.factor

@@ -11,6 +11,7 @@ IN: bootstrap.x86
 : temp-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;
+: rs-reg ( -- reg ) R15 ;
 : fixnum>slot@ ( -- ) ;
 : rex-length ( -- n ) 1 ;
 

core/cpu/x86/bootstrap.factor

@@ -74,6 +74,90 @@ big-endian off
     arg0 quot-xt-offset [+] JMP                ! execute branch
 ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
 
+[
+    arg1 ds-reg [] MOV                         ! load from stack
+    arg1 tag-mask get AND                      ! compute tag
+    arg1 tag-bits get SHL                      ! tag the tag
+    ds-reg [] arg1 MOV                         ! push to stack
+] f f f jit-tag jit-define
+
+: jit-compare ( -- )
+    arg1 0 MOV                                 ! load t
+    arg1 dup [] MOV
+    temp-reg \ f tag-number MOV                ! load f
+    arg0 ds-reg [] MOV                         ! load first value
+    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    ds-reg [] arg0 CMP                         ! compare with second value
+    ;
+
+[
+    jit-compare
+    arg1 temp-reg CMOVNE                       ! not equal?
+    ds-reg [] arg1 MOV                         ! store
+] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
+
+[
+    arg0 ds-reg [] MOV                         ! load slot number
+    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    arg1 ds-reg [] MOV                         ! load object
+    fixnum>slot@                               ! turn slot number into offset
+    arg1 tag-bits get SHR                      ! mask off tag
+    arg1 tag-bits get SHL
+    arg0 arg1 arg0 [+] MOV                     ! load slot value
+    ds-reg [] arg0 MOV                         ! push to stack
+] f f f jit-slot jit-define
+
+[
+    ds-reg bootstrap-cell SUB
+] f f f jit-drop jit-define
+
+[
+    arg0 ds-reg [] MOV
+    ds-reg bootstrap-cell ADD
+    ds-reg [] arg0 MOV
+] f f f jit-dup jit-define
+
+[
+    rs-reg bootstrap-cell ADD
+    arg0 ds-reg [] MOV
+    ds-reg bootstrap-cell SUB
+    rs-reg [] arg0 MOV
+] f f f jit->r jit-define
+
+[
+    ds-reg bootstrap-cell ADD
+    arg0 rs-reg [] MOV
+    rs-reg bootstrap-cell SUB
+    ds-reg [] arg0 MOV
+] f f f jit-r> jit-define
+
+[
+    arg0 ds-reg [] MOV
+    arg1 ds-reg bootstrap-cell neg [+] MOV
+    ds-reg bootstrap-cell neg [+] arg0 MOV
+    ds-reg [] arg1 MOV
+] f f f jit-swap jit-define
+
+[
+    arg0 ds-reg bootstrap-cell neg [+] MOV
+    ds-reg bootstrap-cell ADD
+    ds-reg [] arg0 MOV
+] f f f jit-over jit-define
+
+[
+    arg0 ds-reg [] MOV
+    ds-reg bootstrap-cell SUB
+    arg1 ds-reg [] MOV
+    arg1 arg0 SUB
+    ds-reg [] arg1 MOV
+] f f f jit-fixnum-fast jit-define
+
+[
+    jit-compare
+    arg1 temp-reg CMOVL                        ! not equal?
+    ds-reg [] arg1 MOV                         ! store
+] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define
+
 [
     stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
 ] f f f jit-epilog jit-define

core/generator/generator.factor

@@ -32,7 +32,7 @@ SYMBOL: compiling-loops
 ! Label of current word, after prologue, makes recursion faster
 SYMBOL: current-label-start
 
-: compiled-stack-traces? ( -- ? ) 36 getenv ;
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
 
 : begin-compiling ( word label -- )
     H{ } clone compiling-loops set

core/generator/registers/registers.factor

@@ -562,13 +562,10 @@ M: loc lazy-store
         2drop t
     ] if ;
 
-: class-tag ( class -- tag/f )
-    dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ;
-
 : class-matches? ( actual expected -- ? )
     {
         { f [ drop t ] }
-        { known-tag [ class-tag >boolean ] }
+        { known-tag [ dup [ class-tag >boolean ] when ] }
         [ class<= ]
     } case ;
 
@@ -639,7 +636,7 @@ PRIVATE>
     [ second template-matches? ] find nip ;
 
 : operand-tag ( operand -- tag/f )
-    operand-class class-tag ;
+    operand-class dup [ class-tag ] when ;
 
 UNION: immediate fixnum POSTPONE: f ;
 

core/generic/standard/engines/engines.factor

@@ -22,7 +22,11 @@ GENERIC: engine>quot ( engine -- quot )
 
 : linear-dispatch-quot ( alist -- quot )
     default get [ drop ] prepend swap
-    [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+    [
+        [ [ dup ] swap [ eq? ] curry compose ]
+        [ [ drop ] prepose ]
+        bi* [ ] like
+    ] assoc-map
     alist>quot ;
 
 : split-methods ( assoc class -- first second )

core/generic/standard/engines/tag/tag.factor

@@ -44,7 +44,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
     "type" word-prop num-tags get - ;
 
 : hi-tag-quot ( -- quot )
-    [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
+    [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
 
 M: hi-tag-dispatch-engine engine>quot
     methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map

core/generic/standard/engines/tuple/tuple.factor

@@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ;
 
 : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
 
-: tuple-layout-superclasses ( obj -- array )
+: tuple-layout-superclasses% ( -- )
-    { tuple } declare
+    [
-    1 slot { tuple-layout } declare
+        { tuple } declare
-    4 slot { array } declare ; inline
+        1 slot { tuple-layout } declare
+        4 slot { array } declare
+    ] % ; inline
 
 : tuple-dispatch-engine-body ( engine -- quot )
     [
         picker %
-        [ tuple-layout-superclasses ] %
+        tuple-layout-superclasses%
         [ n>> array-nth% ]
         [
             methods>> [
@@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot
     ] [
         [
             picker %
-            [ tuple-layout-superclasses ] %
+            tuple-layout-superclasses%
             [ n>> array-nth% ]
             [
                 methods>> [
@@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot
 
 : >=-case-quot ( alist -- quot )
     default get [ drop ] prepend swap
-    [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+    [
+        [ [ dup ] swap [ fixnum>= ] curry compose ]
+        [ [ drop ] prepose ]
+        bi* [ ] like
+    ] assoc-map
     alist>quot ;
 
-: tuple-layout-echelon ( obj -- array )
+: tuple-layout-echelon% ( -- )
-    { tuple } declare
+    [
-    1 slot { tuple-layout } declare
+        { tuple } declare
-    5 slot ; inline
+        1 slot { tuple-layout } declare
+        5 slot
+    ] % ; inline
 
 M: tuple-dispatch-engine engine>quot
     [
         picker %
-        [ tuple-layout-echelon ] %
+        tuple-layout-echelon%
         [
             tuple assumed set
             echelons>> dup empty? [

core/io/streams/c/c.factor

@@ -58,7 +58,7 @@ M: object init-io ;
 
 : stdin-handle 11 getenv ;
 : stdout-handle 12 getenv ;
-: stderr-handle 38 getenv ;
+: stderr-handle 61 getenv ;
 
 M: object (init-stdio)
     stdin-handle <c-reader>

core/math/intervals/intervals.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
 USING: accessors kernel sequences arrays math math.order
-combinators ;
+combinators generic ;
 IN: math.intervals
 
 TUPLE: interval { from read-only } { to read-only } ;
@@ -177,6 +177,11 @@ C: <interval> interval
 : interval/ ( i1 i2 -- i3 )
     [ [ / ] interval-op ] interval-division-op ;
 
+: interval/-safe ( i1 i2 -- i3 )
+    #! Just a hack to make the compiler work if bootstrap.math
+    #! is not loaded.
+    \ integer \ / method [ interval/ ] [ 2drop f ] if ;
+
 : interval/i ( i1 i2 -- i3 )
     [
         [ [ /i ] interval-op ] interval-integer-op

core/optimizer/math/math.factor

@@ -158,7 +158,7 @@ optimizer.math.partial generic.standard system accessors ;
     { + { { fixnum integer } } interval+ }
     { - { { fixnum integer } } interval- }
     { * { { fixnum integer } } interval* }
-    { / { { fixnum rational } { integer rational } } interval/ }
+    { / { { fixnum rational } { integer rational } } interval/-safe }
     { /i { { fixnum integer } } interval/i }
     { shift { { fixnum integer } } interval-shift-safe }
 } [

core/threads/threads.factor

@@ -15,7 +15,7 @@ id
 continuation state runnable
 mailbox variables sleep-entry ;
 
-: self ( -- thread ) 40 getenv ; inline
+: self ( -- thread ) 63 getenv ; inline
 
 ! Thread-local storage
 : tnamespace ( -- assoc )
@@ -30,7 +30,7 @@ mailbox variables sleep-entry ;
 : tchange ( key quot -- )
     tnamespace swap change-at ; inline
 
-: threads 41 getenv ;
+: threads 64 getenv ;
 
 : thread ( id -- thread ) threads at ;
 
@@ -53,7 +53,7 @@ mailbox variables sleep-entry ;
 : unregister-thread ( thread -- )
     check-registered id>> threads delete-at ;
 
-: set-self ( thread -- ) 40 setenv ; inline
+: set-self ( thread -- ) 63 setenv ; inline
 
 PRIVATE>
 
@@ -68,9 +68,9 @@ PRIVATE>
 : <thread> ( quot name -- thread )
     \ thread new-thread ;
 
-: run-queue 42 getenv ;
+: run-queue 65 getenv ;
 
-: sleep-queue 43 getenv ;
+: sleep-queue 66 getenv ;
 
 : resume ( thread -- )
     f >>state
@@ -207,9 +207,9 @@ GENERIC: error-in-thread ( error thread -- )
 <PRIVATE
 
 : init-threads ( -- )
-    H{ } clone 41 setenv
+    H{ } clone 64 setenv
-    <dlist> 42 setenv
+    <dlist> 65 setenv
-    <min-heap> 43 setenv
+    <min-heap> 66 setenv
     initial-thread global
     [ drop f "Initial" <thread> ] cache
     <box> >>continuation

extra/bit-arrays/bit-arrays.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types accessors math alien.accessors kernel
-kernel.private sequences sequences.private byte-arrays
+kernel.private locals sequences sequences.private byte-arrays
 parser prettyprint.backend ;
 IN: bit-arrays
 
@@ -72,14 +72,16 @@ M: bit-array byte-length length 7 + -3 shift ;
 : ?{ ( parsed -- parsed )
     \ } [ >bit-array ] parse-literal ; parsing
 
-: integer>bit-array ( int -- bit-array ) 
+:: integer>bit-array ( n -- bit-array ) 
-    dup zero? [ drop 0 <bit-array> ] [
+    n zero? [ 0 <bit-array> ] [
-        [ log2 1+ <bit-array> 0 ] keep
+        [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
-        [ dup zero? not ] [
+            [ n' zero? not ] [
-            [ -8 shift ] [ 255 bitand ] bi
+                n' out underlying>> i 255 bitand set-alien-unsigned-1
-            -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip
+                n' -8 shift n'!
-        ] [ ] while
+                i 1+ i!
-        2drop
+            ] [ ] while
+            out
+        ]
     ] if ;
 
 : bit-array>integer ( bit-array -- int )

extra/columns/columns-docs.factor

@@ -11,7 +11,7 @@ HELP: column
 
 HELP: <column> ( seq n -- column )
 { $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
-{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
+{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
 { $examples
     { $example
         "USING: arrays prettyprint columns ;"

extra/ctags/authors.txt

@@ -0,0 +1 @@
+Alfredo Beaumont

extra/ctags/ctags-docs.factor

@@ -0,0 +1,60 @@
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+IN: ctags
+
+ARTICLE: "ctags" "Ctags file"
+{ $emphasis "ctags" } " generates a index file of every factor word in ctags format as supported by vi and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags" } "."
+{ $subsection ctags }
+{ $subsection ctags-write }
+{ $subsection ctag-strings }
+{ $subsection ctag } ;
+
+HELP: ctags ( path -- )
+{ $values { "path" "a pathname string" } }
+{ $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." }
+{ $examples
+  { $example
+    "USING: ctags ;"
+    "\"tags\" ctags-write"
+    ""
+  }
+} ;
+
+HELP: ctags-write ( seq path -- )
+{ $values { "alist" "an association list" }
+          { "path" "a pathname string" } }
+{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" }
+{ $examples
+  { $example
+    "USING: kernel ctags ;"
+    "{ { if  { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write"
+    ""
+  }
+}
+{ $notes
+  { $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ;
+
+HELP: ctag-strings ( alist -- seq )
+{ $values { "alist" "an association list" }
+          { "seq" sequence } }
+{ $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." }
+{ $examples
+  { $example
+    "USING: kernel ctags ;"
+    "{ { if  { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings"
+    "{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }"
+  }
+} ;
+
+HELP: ctag ( seq -- str )
+{ $values { "seq" sequence }
+          { "str" string } }
+{ $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" }
+{ $examples
+  { $example
+    "USING: kernel ctags ;"
+    "{ if  { \"resource:extra/unix/unix.factor\" 91 } } ctag ."
+    "\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\""
+  }
+} ;
+
+ABOUT: "ctags"

extra/ctags/ctags-tests.factor

@@ -0,0 +1,12 @@
+USING: kernel ctags tools.test io.backend sequences arrays prettyprint ;
+IN: ctags.tests
+
+[ t ] [
+  "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append
+  { if  { "resource:extra/unix/unix.factor" 91 } } ctag =
+] unit-test
+
+[ t ] [
+  "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array
+  { { if  { "resource:extra/unix/unix.factor" 91 } } } ctag-strings =
+] unit-test

extra/ctags/ctags.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Alfredo Beaumont
+! See http://factorcode.org/license.txt for BSD license.
+
+! Simple Ctags generator
+! Alfredo Beaumont <alfredo.beaumont@gmail.com>
+
+USING: arrays kernel sequences io io.files io.backend
+io.encodings.ascii math.parser vocabs definitions
+namespaces words sorting ;
+IN: ctags
+
+: ctag ( seq -- str )
+  [
+    dup first ?word-name %
+    "\t" %
+    second dup first normalize-path %
+    "\t" %
+    second number>string %
+  ] "" make ;
+
+: ctag-strings ( seq1 -- seq2 )
+  { } swap [ ctag suffix ] each ;
+
+: ctags-write ( seq path -- )
+  >r ctag-strings r> ascii set-file-lines ;
+
+: (ctags) ( -- seq )
+  { } all-words [
+    dup where [
+      2array suffix
+    ] [
+      drop
+    ] if*
+  ] each ;
+
+: ctags ( path -- )
+  (ctags) sort-keys swap ctags-write ;

extra/ctags/summary.txt

@@ -0,0 +1 @@
+Ctags generator

extra/tools/walker/walker-tests.factor

@@ -1,7 +1,7 @@
 USING: tools.walker io io.streams.string kernel math
 math.private namespaces prettyprint sequences tools.test
 continuations math.parser threads arrays tools.walker.debug
-generic.standard ;
+generic.standard sequences.private kernel.private ;
 IN: tools.walker.tests
 
 [ { } ] [
@@ -50,6 +50,10 @@ IN: tools.walker.tests
     [ 5 6 number= ] test-walker
 ] unit-test
 
+[ { 0 } ] [
+    [ 0 { array-capacity } declare ] test-walker
+] unit-test
+
 [ { f } ] [
     [ "XYZ" "XYZ" mismatch ] test-walker
 ] unit-test

vm/os-unix.c

@@ -322,8 +322,16 @@ void safe_write(int fd, void *data, size_t size)
 
 void safe_read(int fd, void *data, size_t size)
 {
-	if(read(fd,data,size) != size)
+	ssize_t bytes = read(fd,data,size);
-		fatal_error("error reading fd",errno);
+	if(bytes < 0)
+	{
+		if(errno == EINTR)
+			safe_read(fd,data,size);
+		else
+			fatal_error("error reading fd",errno);
+	}
+	else if(bytes != size)
+		fatal_error("unexpected eof on fd",bytes);
 }
 
 void *stdin_loop(void *arg)

vm/os-unix.h

@@ -27,6 +27,8 @@ typedef char F_SYMBOL;
 #define OPEN_WRITE(path) fopen(path,"wb")
 #define FPRINTF(stream,format,arg) fprintf(stream,format,arg)
 
+void start_thread(void *(*start_routine)(void *));
+
 void init_ffi(void);
 void ffi_dlopen(F_DLL *dll);
 void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);

vm/quotations.c

@@ -25,6 +25,13 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
 		&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
 }
 
+bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
+{
+	return (i + 1) < array_capacity(array)
+		&& type_of(array_nth(array,i)) == ARRAY_TYPE
+		&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
+}
+
 F_ARRAY *code_to_emit(CELL name)
 {
 	return untag_object(array_nth(untag_object(userenv[name]),0));
@@ -72,8 +79,24 @@ bool jit_stack_frame_p(F_ARRAY *array)
 
 	for(i = 0; i < length - 1; i++)
 	{
-		if(type_of(array_nth(array,i)) == WORD_TYPE)
+		CELL obj = array_nth(array,i);
-			return true;
+		if(type_of(obj) == WORD_TYPE)
+		{
+			if(obj != userenv[JIT_TAG_WORD]
+				&& obj != userenv[JIT_EQP_WORD]
+				&& obj != userenv[JIT_SLOT_WORD]
+				&& obj != userenv[JIT_DROP_WORD]
+				&& obj != userenv[JIT_DUP_WORD]
+				&& obj != userenv[JIT_TO_R_WORD]
+				&& obj != userenv[JIT_FROM_R_WORD]
+				&& obj != userenv[JIT_SWAP_WORD]
+				&& obj != userenv[JIT_OVER_WORD]
+				&& obj != userenv[JIT_FIXNUM_MINUS_WORD]
+				&& obj != userenv[JIT_FIXNUM_GE_WORD])
+			{
+				return true;
+			}
+		}
 	}
 
 	return false;
@@ -131,24 +154,74 @@ void jit_compile(CELL quot, bool relocate)
 		switch(type_of(obj))
 		{
 		case WORD_TYPE:
-			/* Emit the epilog before the primitive call gate
+			/* Intrinsics */
-			so that we save the C stack pointer minus the
+			if(obj == userenv[JIT_TAG_WORD])
-			current stack frame. */
-			word = untag_object(obj);
-
-			GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
-
-			if(i == length - 1)
 			{
-				if(stack_frame)
+				EMIT(JIT_TAG,0);
-					EMIT(JIT_EPILOG,0);
+			}
-
+			else if(obj == userenv[JIT_EQP_WORD])
-				EMIT(JIT_WORD_JUMP,literals_count - 1);
+			{
-
+				GROWABLE_ARRAY_ADD(literals,T);
-				tail_call = true;
+				EMIT(JIT_EQP,literals_count - 1);
+			}
+			else if(obj == userenv[JIT_SLOT_WORD])
+			{
+				EMIT(JIT_SLOT,0);
+			}
+			else if(obj == userenv[JIT_DROP_WORD])
+			{
+				EMIT(JIT_DROP,0);
+			}
+			else if(obj == userenv[JIT_DUP_WORD])
+			{
+				EMIT(JIT_DUP,0);
+			}
+			else if(obj == userenv[JIT_TO_R_WORD])
+			{
+				EMIT(JIT_TO_R,0);
+			}
+			else if(obj == userenv[JIT_FROM_R_WORD])
+			{
+				EMIT(JIT_FROM_R,0);
+			}
+			else if(obj == userenv[JIT_SWAP_WORD])
+			{
+				EMIT(JIT_SWAP,0);
+			}
+			else if(obj == userenv[JIT_OVER_WORD])
+			{
+				EMIT(JIT_OVER,0);
+			}
+			else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
+			{
+				EMIT(JIT_FIXNUM_MINUS,0);
+			}
+			else if(obj == userenv[JIT_FIXNUM_GE_WORD])
+			{
+				GROWABLE_ARRAY_ADD(literals,T);
+				EMIT(JIT_FIXNUM_GE,literals_count - 1);
 			}
 			else
-				EMIT(JIT_WORD_CALL,literals_count - 1);
+			{
+				/* Emit the epilog before the primitive call gate
+				so that we save the C stack pointer minus the
+				current stack frame. */
+				word = untag_object(obj);
+
+				GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
+
+				if(i == length - 1)
+				{
+					if(stack_frame)
+						EMIT(JIT_EPILOG,0);
+
+					EMIT(JIT_WORD_JUMP,literals_count - 1);
+
+					tail_call = true;
+				}
+				else
+					EMIT(JIT_WORD_CALL,literals_count - 1);
+			}
 			break;
 		case WRAPPER_TYPE:
 			wrapper = untag_object(obj);
@@ -194,6 +267,11 @@ void jit_compile(CELL quot, bool relocate)
 				tail_call = true;
 				break;
 			}
+			else if(jit_ignore_declare_p(untag_object(array),i))
+			{
+				i++;
+				break;
+			}
 		default:
 			GROWABLE_ARRAY_ADD(literals,obj);
 			EMIT(JIT_PUSH_LITERAL,literals_count - 1);
@@ -261,24 +339,47 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
 	for(i = 0; i < length; i++)
 	{
 		CELL obj = array_nth(untag_object(array),i);
-		F_WORD *word;
 
 		switch(type_of(obj))
 		{
 		case WORD_TYPE:
-			word = untag_object(obj);
+			/* Intrinsics */
-
+			if(obj == userenv[JIT_TAG_WORD])
-			if(i == length - 1)
+				COUNT(JIT_TAG,i)
-			{
+			else if(obj == userenv[JIT_EQP_WORD])
-				if(stack_frame)
+				COUNT(JIT_EQP,i)
-					COUNT(JIT_EPILOG,i);
+			else if(obj == userenv[JIT_SLOT_WORD])
-
+				COUNT(JIT_SLOT,i)
-				COUNT(JIT_WORD_JUMP,i)
+			else if(obj == userenv[JIT_DROP_WORD])
-
+				COUNT(JIT_DROP,i)
-				tail_call = true;
+			else if(obj == userenv[JIT_DUP_WORD])
-			}
+				COUNT(JIT_DUP,i)
+			else if(obj == userenv[JIT_TO_R_WORD])
+				COUNT(JIT_TO_R,i)
+			else if(obj == userenv[JIT_FROM_R_WORD])
+				COUNT(JIT_FROM_R,i)
+			else if(obj == userenv[JIT_SWAP_WORD])
+				COUNT(JIT_SWAP,i)
+			else if(obj == userenv[JIT_OVER_WORD])
+				COUNT(JIT_OVER,i)
+			else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
+				COUNT(JIT_FIXNUM_MINUS,i)
+			else if(obj == userenv[JIT_FIXNUM_GE_WORD])
+				COUNT(JIT_FIXNUM_GE,i)
 			else
-				COUNT(JIT_WORD_CALL,i)
+			{
+				if(i == length - 1)
+				{
+					if(stack_frame)
+						COUNT(JIT_EPILOG,i);
+	
+					COUNT(JIT_WORD_JUMP,i)
+	
+					tail_call = true;
+				}
+				else
+					COUNT(JIT_WORD_CALL,i)
+			}
 			break;
 		case WRAPPER_TYPE:
 			COUNT(JIT_PUSH_LITERAL,i)
@@ -319,6 +420,14 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
 				tail_call = true;
 				break;
 			}
+			if(jit_ignore_declare_p(untag_object(array),i))
+			{
+				if(offset == 0) return i;
+
+				i++;
+
+				break;
+			}
 		default:
 			COUNT(JIT_PUSH_LITERAL,i)
 			break;

vm/run.h

@@ -1,4 +1,4 @@
-#define USER_ENV 64
+#define USER_ENV 70
 
 typedef enum {
 	NAMESTACK_ENV,            /* used by library only */
@@ -47,20 +47,43 @@ typedef enum {
 	JIT_EPILOG,
 	JIT_RETURN,
 	JIT_PROFILING,
+	JIT_TAG,
+	JIT_TAG_WORD,
+	JIT_EQP,
+	JIT_EQP_WORD,
+	JIT_SLOT,
+	JIT_SLOT_WORD,
+	JIT_DECLARE_WORD,
+	JIT_DROP,
+	JIT_DROP_WORD,
+	JIT_DUP,
+	JIT_DUP_WORD,
+	JIT_TO_R,
+	JIT_TO_R_WORD,
+	JIT_FROM_R,
+	JIT_FROM_R_WORD,
+	JIT_SWAP,
+	JIT_SWAP_WORD,
+	JIT_OVER,
+	JIT_OVER_WORD,
+	JIT_FIXNUM_MINUS,
+	JIT_FIXNUM_MINUS_WORD,
+	JIT_FIXNUM_GE,
+	JIT_FIXNUM_GE_WORD,
 
-	STACK_TRACES_ENV    = 36,
+	STACK_TRACES_ENV    = 59,
 
-	UNDEFINED_ENV       = 37, /* default quotation for undefined words */
+	UNDEFINED_ENV       = 60, /* default quotation for undefined words */
 
-	STDERR_ENV          = 38, /* stderr FILE* handle */
+	STDERR_ENV          = 61, /* stderr FILE* handle */
 
-	STAGE2_ENV          = 39, /* have we bootstrapped? */
+	STAGE2_ENV          = 62, /* have we bootstrapped? */
 
-	CURRENT_THREAD_ENV  = 40,
+	CURRENT_THREAD_ENV  = 63,
 
-	THREADS_ENV         = 41,
+	THREADS_ENV         = 64,
-	RUN_QUEUE_ENV       = 42,
+	RUN_QUEUE_ENV       = 65,
-	SLEEP_QUEUE_ENV     = 43,
+	SLEEP_QUEUE_ENV     = 66,
 } F_ENVTYPE;
 
 #define FIRST_SAVE_ENV BOOT_ENV