Merge git://factorcode.org/git/factor

core/compiler/compiler.factor

@@ -26,7 +26,7 @@ IN: compiler
     >r dupd save-effect r>
     f pick compiler-error
     over compiled-unxref
-    compiled-xref ;
+    over crossref? [ compiled-xref ] [ 2drop ] if ;
 
 : compile-succeeded ( word -- effect dependencies )
     [

core/cpu/x86/32/32.factor

@@ -261,6 +261,10 @@ windows? [
     cell "ulonglong" c-type set-c-type-align
 ] unless
 
+macosx? [
+    cell "double" c-type set-c-type-align
+] when
+
 T{ x86-backend f 4 } compiler-backend set-global
 
 : sse2? "Intrinsic" throw ;

core/effects/effects.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces sequences strings words assocs
 combinators ;
@@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ;
         ")" %
     ] "" make ;
 
-: stack-effect ( word -- effect/f )
+GENERIC: stack-effect ( word -- effect/f )
-    {
+
-        { [ dup symbol? ] [ drop 0 1 <effect> ] }
+M: symbol stack-effect drop 0 1 <effect> ;
-        { [ dup "parent-generic" word-prop ] [
+
-            "parent-generic" word-prop stack-effect
+M: word stack-effect
-        ] }
+    { "declared-effect" "inferred-effect" }
-        { [ t ] [
+    swap word-props [ at ] curry map [ ] find nip ;
-            { "declared-effect" "inferred-effect" }
-            swap word-props [ at ] curry map [ ] find nip
-        ] }
-    } cond ;
 
 M: effect clone
     [ effect-in clone ] keep effect-out clone <effect> ;

core/generic/generic-docs.factor

@@ -107,10 +107,6 @@ HELP: make-generic
 { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
 $low-level-note ;
 
-HELP: init-methods
-{ $values { "word" word } }
-{ $description "Prepare to define a generic word." } ;
-
 HELP: define-generic
 { $values { "word" word } { "combination" "a method combination" } }
 { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }

core/generic/generic-tests.factor

@@ -176,6 +176,9 @@ M: f tag-and-f 4 ;
 ! define-class hashing issue
 TUPLE: debug-combination ;
 
+M: debug-combination make-default-method
+    2drop [ "Oops" throw ] when ;
+
 M: debug-combination perform-combination
     drop
     order [ dup class-hashes ] { } map>assoc sort-keys

core/generic/generic.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words kernel sequences namespaces assocs hashtables
 definitions kernel.private classes classes.private
-quotations arrays vocabs ;
+quotations arrays vocabs effects ;
 IN: generic
 
 ! Method combination protocol
@@ -65,15 +65,20 @@ TUPLE: check-method class generic ;
 : make-method-def ( quot word combination -- quot )
     "combination" word-prop method-prologue swap append ;
 
+PREDICATE: word method-body "method" word-prop >boolean ;
+
+M: method-body stack-effect
+    "method" word-prop method-generic stack-effect ;
+
 : <method-word> ( quot class generic -- word )
     [ make-method-def ] 2keep
-    [ method-word-name f <word> dup ] keep
+    method-word-name f <word>
-    "parent-generic" set-word-prop
     dup rot define ;
 
 : <method> ( quot class generic -- method )
     check-method
-    [ <method-word> ] 3keep f \ method construct-boa ;
+    [ <method-word> ] 3keep f \ method construct-boa
+    dup method-word over "method" set-word-prop ;
 
 : define-method ( quot class generic -- )
     >r bootstrap-word r>
@@ -120,13 +125,22 @@ M: class forget* ( class -- )
 M: assoc update-methods ( assoc -- )
     implementors* [ make-generic ] each ;
 
-: init-methods ( word -- )
-     dup "methods" word-prop
-     H{ } assoc-like
-     "methods" set-word-prop ;
-
 : define-generic ( word combination -- )
-    2dup "combination" set-word-prop
+    over "combination" word-prop over = [
-    dupd define-default-method
+        2drop
-    dup init-methods
+    ] [
-    make-generic ;
+        2dup "combination" set-word-prop
+        over H{ } clone "methods" set-word-prop
+        dupd define-default-method
+        make-generic
+    ] if ;
+
+: subwords ( generic -- seq )
+    dup "methods" word-prop values
+    swap "default-method" word-prop add
+    [ method-word ] map ;
+
+: xref-generics ( -- )
+    all-words
+    [ generic? ] subset
+    [ subwords [ xref ] each ] each ;

core/generic/standard/standard.factor

@@ -10,7 +10,7 @@ TUPLE: standard-combination # ;
 
 M: standard-combination method-prologue
     standard-combination-# object
-    <array> swap add [ declare ] curry ;
+    <array> swap add* [ declare ] curry ;
 
 C: <standard-combination> standard-combination
 

core/inference/backend/backend.factor

@@ -10,8 +10,8 @@ IN: inference.backend
     recursive-state get at ;
 
 : inline? ( word -- ? )
-    dup "parent-generic" word-prop
+    dup "method" word-prop
-    [ inline? ] [ "inline" word-prop ] ?if ;
+    [ method-generic inline? ] [ "inline" word-prop ] ?if ;
 
 : local-recursive-state ( -- assoc )
     recursive-state get dup keys

core/io/crc32/crc32-docs.factor

@@ -2,16 +2,16 @@ USING: help.markup help.syntax math ;
 IN: io.crc32
 
 HELP: crc32
-{ $values { "seq" "a sequence" } { "n" integer } }
+{ $values { "seq" "a sequence of bytes" } { "n" integer } }
 { $description "Computes the CRC32 checksum of a sequence of bytes." } ;
 
-HELP: file-crc32
+HELP: lines-crc32
-{ $values { "path" "a pathname string" } { "n" integer } }
+{ $values { "lines" "a sequence of strings" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a file's contents." } ;
+{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
 
 ARTICLE: "io.crc32" "CRC32 checksum calculation"
 "The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
 { $subsection crc32 }
-{ $subsection file-crc32 } ;
+{ $subsection lines-crc32 } ;
 
 ABOUT: "io.crc32"

core/io/crc32/crc32.factor

@@ -23,8 +23,6 @@ IN: io.crc32
 : crc32 ( seq -- n )
     >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: file-crc32 ( path -- n ) file-contents crc32 ;
-
 : lines-crc32 ( seq -- n )
     HEX: ffffffff tuck [
         [ (crc32) ] each CHAR: \n (crc32)

core/io/streams/c/c.factor

@@ -74,3 +74,10 @@ M: object <file-writer>
 
 M: object <file-appender>
     "ab" fopen <c-writer> <plain-writer> ;
+
+: show ( msg -- )
+    #! A word which directly calls primitives. It is used to
+    #! print stuff from contexts where the I/O system would
+    #! otherwise not work (tools.deploy.shaker, the I/O
+    #! multiplexer thread).
+    "\r\n" append stdout-handle fwrite stdout-handle fflush ;

core/source-files/source-files.factor

@@ -17,7 +17,7 @@ uses definitions ;
 
 : (source-modified?) ( path modified checksum -- ? )
     pick file-modified rot [ 0 or ] 2apply >
-    [ swap file-crc32 number= not ] [ 2drop f ] if ;
+    [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ;
 
 : source-modified? ( path -- ? )
     dup source-files get at [

core/words/words.factor

@@ -116,13 +116,16 @@ SYMBOL: changed-words
     [ no-compilation-unit ] unless*
     set-at ;
 
+: crossref? ( word -- ? )
+    dup word-vocabulary swap "method" word-prop or ;
+
 : define ( word def -- )
     [ ] like
     over unxref
     over redefined
     over set-word-def
     dup changed-word
-    dup word-vocabulary [ dup xref ] when drop ;
+    dup crossref? [ dup xref ] when drop ;
 
 : define-declared ( word def effect -- )
     pick swap "declared-effect" set-word-prop

extra/io/launcher/launcher-docs.factor

@@ -146,8 +146,8 @@ HELP: with-process-stream
 { $values
   { "desc" "a launch descriptor" }
   { "quot" quotation }
-  { "process" process } }
+  { "status" "an exit code" } }
-{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
+{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
 
 HELP: wait-for-process
 { $values { "process" process } { "status" integer } }

extra/io/launcher/launcher.factor

@@ -98,10 +98,10 @@ TUPLE: process-stream process ;
     { set-delegate set-process-stream-process }
     process-stream construct ;
 
-: with-process-stream ( desc quot -- process )
+: with-process-stream ( desc quot -- status )
     swap <process-stream>
     [ swap with-stream ] keep
-    process-stream-process ; inline
+    process-stream-process wait-for-process ; inline
 
 : notify-exit ( status process -- )
     [ set-process-status ] keep

extra/io/monitor/monitor.factor

@@ -17,7 +17,7 @@ TUPLE: monitor queue closed? ;
         set-monitor-queue
     } monitor construct ;
 
-HOOK: fill-queue io-backend ( monitor -- assoc )
+HOOK: fill-queue io-backend ( monitor -- )
 
 : changed-file ( changed path -- )
     namespace [ append ] change-at ;
@@ -32,7 +32,7 @@ HOOK: <monitor> io-backend ( path recursive? -- monitor )
 : next-change ( monitor -- path changed )
     dup check-monitor
     dup monitor-queue dup assoc-empty? [
-        drop dup fill-queue over set-monitor-queue next-change
+        drop dup fill-queue next-change
     ] [ nip dequeue-change ] if ;
 
 SYMBOL: +add-file+

extra/io/unix/linux/linux.factor

@@ -54,21 +54,22 @@ TUPLE: inotify watches ;
 M: linux-io <monitor> ( path recursive? -- monitor )
     drop IN_CHANGE_EVENTS add-watch ;
 
-: notify-callback ( assoc monitor -- )
+: notify-callback ( monitor -- )
-    linux-monitor-callback dup
+    dup linux-monitor-callback
-    [ schedule-thread-with ] [ 2drop ] if ;
+    f rot set-linux-monitor-callback
+    [ schedule-thread ] when* ;
 
-M: linux-io fill-queue ( monitor -- assoc )
+M: linux-io fill-queue ( monitor -- )
     dup linux-monitor-callback [
         "Cannot wait for changes on the same file from multiple threads" throw
     ] when
-    [ swap set-linux-monitor-callback stop ] callcc1
+    [ swap set-linux-monitor-callback stop ] callcc0
-    swap check-monitor ;
+    check-monitor ;
 
 M: linux-monitor dispose ( monitor -- )
     dup check-monitor
     t over set-monitor-closed?
-    H{ } over notify-callback
+    dup notify-callback
     remove-watch ;
 
 : ?flag ( n mask symbol -- n )
@@ -106,13 +107,13 @@ M: linux-monitor dispose ( monitor -- )
     inotify-event-len "inotify-event" heap-size +
     swap >r + r> ;
 
-: wd>queue ( wd -- queue )
-    inotify-event-wd wd>monitor monitor-queue ;
-
 : parse-file-notifications ( i buffer -- )
     2dup events-exhausted? [ 2drop ] [
-        2dup inotify-event@ dup inotify-event-wd wd>queue
+        2dup inotify-event@ dup inotify-event-wd wd>monitor [
-        [ parse-file-notify changed-file ] bind
+            monitor-queue [
+                parse-file-notify changed-file
+            ] bind
+        ] keep notify-callback
         next-event parse-file-notifications
     ] if ;
 
@@ -135,7 +136,7 @@ M: inotify-task do-io-task ( task -- )
     io-task-port read-notifications f ;
 
 M: linux-io init-io ( -- )
-    <select-mx> mx set-global ; ! init-inotify ;
+    <select-mx> dup mx set-global init-inotify ;
 
 T{ linux-io } set-io-backend
 

extra/io/windows/nt/monitor/monitor.factor

@@ -78,6 +78,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
     dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
     [ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;
 
-M: windows-nt-io fill-queue ( monitor -- assoc )
+M: windows-nt-io fill-queue ( monitor -- )
-    dup win32-monitor-path over buffer-ptr rot read-changes
+    dup win32-monitor-path over buffer-ptr pick read-changes
-    [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ;
+    [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc
+    swap set-monitor-queue ;

extra/tools/deploy/shaker/shaker.factor

@@ -8,11 +8,6 @@ debugger io.streams.c io.streams.duplex io.files io.backend
 quotations words.private tools.deploy.config compiler.units ;
 IN: tools.deploy.shaker
 
-: show ( msg -- )
-    #! Use primitives directly so that we can print stuff even
-    #! after most of the image has been stripped away
-    "\r\n" append stdout-handle fwrite stdout-handle fflush ;
-
 : strip-init-hooks ( -- )
     "Stripping startup hooks" show
     "command-line" init-hooks get delete-at

extra/unix/linux/linux.factor

@@ -1,10 +1,8 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: unix
 USING: alien.syntax ;
 
-TYPEDEF: ulong off_t
-
 ! Linux.
 
 : O_RDONLY  HEX: 0000 ; inline

extra/unix/process/process.factor

@@ -32,4 +32,4 @@ IN: unix.process
     fork dup zero? -roll swap curry if ; inline
 
 : wait-for-pid ( pid -- status )
-    0 <int> [ 0 waitpid drop ] keep *int ;
+    0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

extra/unix/solaris/solaris.factor

@@ -3,8 +3,6 @@
 IN: unix
 USING: alien.syntax system kernel ;
 
-TYPEDEF: ulong off_t
-
 ! Solaris.
 
 : O_RDONLY  HEX: 0000 ; inline

extra/unix/unix.factor

@@ -19,11 +19,13 @@ TYPEDEF: uint time_t
 TYPEDEF: uint uid_t
 TYPEDEF: ulong size_t
 TYPEDEF: ulong u_long
-TYPEDEF: ulonglong off_t
 TYPEDEF: ushort mode_t
 TYPEDEF: ushort nlink_t
 TYPEDEF: void* caddr_t
 
+TYPEDEF: ulong off_t
+TYPEDEF-IF: bsd? ulonglong off_t
+
 C-STRUCT: tm
     { "int" "sec" }    ! Seconds: 0-59 (K&R says 0-61?)
     { "int" "min" }    ! Minutes: 0-59
@@ -175,31 +177,39 @@ FUNCTION: int kill ( pid_t pid, int sig ) ;
 
 ! Flags for waitpid
 
-: WNOHANG   1 ;
+: WNOHANG   1 ; inline
-: WUNTRACED 2 ;
+: WUNTRACED 2 ; inline
 
-: WSTOPPED   2 ;
+: WSTOPPED   2 ; inline
-: WEXITED    4 ;
+: WEXITED    4 ; inline
-: WCONTINUED 8 ;
+: WCONTINUED 8 ; inline
-: WNOWAIT    HEX: 1000000 ;
+: WNOWAIT    HEX: 1000000 ; inline
 
 ! Examining status
 
-: WTERMSIG ( status -- value ) HEX: 7f bitand ;
+: WTERMSIG ( status -- value )
+    HEX: 7f bitand ; inline
 
-: WIFEXITED ( status -- ? ) WTERMSIG zero? ;
+: WIFEXITED ( status -- ? )
+    WTERMSIG zero? ; inline
 
-: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ;
+: WEXITSTATUS ( status -- value )
+    HEX: ff00 bitand -8 shift ; inline
 
-: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ;
+: WIFSIGNALED ( status -- ? )
+    HEX: 7f bitand 1+ -1 shift 0 > ; inline
 
-: WCOREFLAG ( -- value ) HEX: 80 ;
+: WCOREFLAG ( -- value )
+    HEX: 80 ; inline
 
-: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ;
+: WCOREDUMP ( status -- ? )
+    WCOREFLAG bitand zero? not ; inline
 
-: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ;
+: WIFSTOPPED ( status -- ? )
+    HEX: ff bitand HEX: 7f = ; inline
 
-: WSTOPSIG ( status -- value ) WEXITSTATUS ;
+: WSTOPSIG ( status -- value )
+    WEXITSTATUS ; inline
 
 FUNCTION: pid_t wait ( int* status ) ;
 FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;