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

core/alien/alien-docs.factor

@@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
 
 HELP: load-library
 { $values { "name" "a string" } { "dll" "a DLL handle" } }
-{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
+{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
 
 HELP: add-library
 { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }

core/alien/alien.factor

@@ -57,7 +57,7 @@ TUPLE: library path abi dll ;
     over dup [ dlopen ] when \ library construct-boa ;
 
 : load-library ( name -- dll )
-    library library-dll ;
+    library dup [ library-dll ] when ;
 
 : add-library ( name path abi -- )
     <library> swap libraries get set-at ;

core/alien/c-types/c-types.factor

@@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
         r> add*
     ] when ;
 
-: malloc-file-contents ( path -- alien )
+: malloc-file-contents ( path -- alien len )
-    binary file-contents malloc-byte-array ;
+    binary file-contents dup malloc-byte-array swap length ;
 
 [
     [ alien-cell ]

core/bootstrap/stage1.factor

@@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
                 "listener" vocab
                 [ restarts. vocab-main execute ]
                 [ die ] if*
+                1 exit
             ] recover
         ] [
             "Cannot find " write write "." print

core/debugger/debugger.factor

@@ -214,7 +214,7 @@ M: check-closed summary
     drop "Attempt to perform I/O on closed stream" ;
 
 M: check-method summary
-    drop "Invalid parameters for define-method" ;
+    drop "Invalid parameters for create-method" ;
 
 M: check-tuple summary
     drop "Invalid class for define-constructor" ;

core/definitions/definitions-tests.factor

@@ -1,10 +1,10 @@
 IN: definitions.tests
 USING: tools.test generic kernel definitions sequences
-compiler.units ;
+compiler.units words ;
 
 TUPLE: combination-1 ;
 
-M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
+M: combination-1 perform-combination 2drop [ ] ;
 
 M: combination-1 make-default-method 2drop [ "No method" throw ] ;
 
@@ -13,7 +13,7 @@ SYMBOL: generic-1
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] object \ generic-1 define-method
+    object \ generic-1 create-method [ ] define
 ] with-compilation-unit
 
 [ ] [

core/generic/generic-docs.factor

@@ -34,7 +34,7 @@ $nl
 { $subsection define-generic }
 { $subsection define-simple-generic }
 "Methods can be added to existing generic words:"
-{ $subsection define-method }
+{ $subsection create-method }
 "Method definitions can be looked up:"
 { $subsection method }
 { $subsection methods }
@@ -123,7 +123,7 @@ HELP: method
 { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
 { $description "Looks up a method definition." } ;
 
-{ method define-method POSTPONE: M: } related-words
+{ method create-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@@ -140,16 +140,17 @@ HELP: order
 HELP: check-method
 { $values { "class" class } { "generic" generic } }
 { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
-{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
+{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
 
 HELP: with-methods
 { $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
 { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
 $low-level-note ;
 
-HELP: define-method
+HELP: create-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
+{ $notes "To define a method, pass the output value to " { $link define } "." } ;
 
 HELP: implementors
 { $values { "class" class } { "seq" "a sequence of generic words" } }

core/generic/generic.factor

@@ -17,10 +17,6 @@ M: object perform-combination
     #! the method will throw an error. We don't want that.
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
-GENERIC: method-prologue ( class combination -- quot )
-
-M: object method-prologue 2drop [ ] ;
-
 GENERIC: make-default-method ( generic combination -- method )
 
 PREDICATE: word generic "combination" word-prop >boolean ;
@@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
 : check-method ( class generic -- class generic )
     over class? over generic? and [
         \ check-method construct-boa throw
-    ] unless ;
+    ] unless ; inline
 
-: with-methods ( word quot -- )
+: with-methods ( generic quot -- )
     swap [ "methods" word-prop swap call ] keep make-generic ;
     inline
 
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-: make-method-def ( quot class generic -- quot )
+PREDICATE: word method-body
-    "combination" word-prop method-prologue swap append ;
+    "method-generic" word-prop >boolean ;
-
-PREDICATE: word method-body "method-def" word-prop >boolean ;
 
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
-: method-word-props ( quot class generic -- assoc )
+: method-word-props ( class generic -- assoc )
     [
         "method-generic" set
         "method-class" set
-        "method-def" set
     ] H{ } make-assoc ;
 
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
     check-method
-    [ make-method-def ] 3keep
     [ method-word-props ] 2keep
     method-word-name f <word>
-    tuck set-word-props
+    [ set-word-props ] keep ;
-    dup rot define ;
 
-: redefine-method ( quot class generic -- )
+: reveal-method ( method class generic -- )
-    [ method swap "method-def" set-word-prop ] 3keep
+    [ set-at ] with-methods ;
-    [ make-method-def ] 2keep
-    method swap define ;
 
-: define-method ( quot class generic -- )
+: create-method ( class generic -- method )
-    >r bootstrap-word r>
+    2dup method dup [
-    2dup method [
+        2nip
-        redefine-method
     ] [
-        [ <method> ] 2keep
+        drop [ <method> dup ] 2keep reveal-method
-        [ set-at ] with-methods
     ] if ;
 
+: <default-method> ( generic combination -- method )
+    object bootstrap-word pick <method>
+    [ -rot make-default-method define ] keep ;
+
 : define-default-method ( generic combination -- )
-    dupd make-default-method object bootstrap-word pick <method>
+    dupd <default-method> "default-method" set-word-prop ;
-    "default-method" set-word-prop ;
 
 ! Definition protocol
 M: method-spec where
@@ -108,11 +98,10 @@ M: method-spec set-where
     first2 method set-where ;
 
 M: method-spec definer
-    drop \ M: \ ; ;
+    first2 method definer ;
 
 M: method-spec definition
-    first2 method dup
+    first2 method definition ;
-    [ "method-def" word-prop ] when ;
 
 : forget-method ( class generic -- )
     check-method
@@ -125,9 +114,6 @@ M: method-spec forget*
 M: method-body definer
     drop \ M: \ ; ;
 
-M: method-body definition
-    "method-def" word-prop ;
-
 M: method-body forget*
     dup "method-class" word-prop
     swap "method-generic" word-prop

core/generic/math/math.factor

@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
 
 : applicable-method ( generic class -- quot )
     over method
-    [ word-def ]
+    [ 1quotation ]
     [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )

core/generic/standard/standard.factor

@@ -8,10 +8,6 @@ IN: generic.standard
 
 TUPLE: standard-combination # ;
 
-M: standard-combination method-prologue
-    standard-combination-# object
-    <array> swap add* [ declare ] curry ;
-
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)

core/io/files/files.factor

@@ -86,16 +86,10 @@ SYMBOL: +unknown+
 : stat ( path -- directory? permissions length modified )
     normalize-pathname (stat) ;
 
-! : file-length ( path -- n ) stat drop 2nip ;
-
 : file-modified ( path -- n ) stat >r 3drop r> ;
 
-! : file-permissions ( path -- perm ) stat 2drop nip ;
-
 : exists? ( path -- ? ) file-modified >boolean ;
 
-! : directory? ( path -- ? ) stat 3drop ;
-
 : directory? ( path -- ? ) file-info file-info-type +directory+ = ;
 
 ! Current working directory
@@ -222,10 +216,7 @@ M: pathname <=> [ pathname-string ] compare ;
     >r <file-reader> r> with-stream ; inline
 
 : file-contents ( path encoding -- str )
-    dupd [ file-info file-info-size read ] with-file-reader ;
+    <file-reader> contents ;
-
-! : file-contents ( path encoding -- str )
-!     dupd [ file-length read ] with-file-reader ;
 
 : with-file-writer ( path encoding quot -- )
     >r <file-writer> r> with-stream ; inline

core/io/io.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables generic kernel math namespaces sequences strings
+USING: hashtables generic kernel math namespaces sequences
-    continuations assocs io.styles sbufs ;
+continuations assocs io.styles ;
 IN: io
 
 GENERIC: stream-readln ( stream -- str )
@@ -88,4 +88,6 @@ SYMBOL: stderr
     [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
 
 : contents ( stream -- str )
-    2048 <sbuf> [ stream-copy ] keep >string ;
+    [
+        [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+    ] with-stream  ;

core/optimizer/specializers/specializers.factor

@@ -24,20 +24,40 @@ IN: optimizer.specializers
         \ dispatch ,
     ] [ ] make ;
 
-: specializer-methods ( quot word -- default alist )
+: specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
         [ declare ] curry pick append
     ] { } map>assoc ;
 
+: method-declaration ( method -- quot )
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop add* ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration [ declare ] curry swap append ;
+
+: specialize-quot ( quot specializer -- quot' )
+    dup { number } = [
+        drop tag-specializer
+    ] [
+        specializer-cases alist>quot
+    ] if ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
 : specialized-def ( word -- quot )
-    dup word-def swap "specializer" word-prop [
+    dup word-def swap {
-        dup { number } = [
+        { [ dup standard-method? ] [ specialize-method ] }
-            drop tag-specializer
+        {
-        ] [
+            [ dup "specializer" word-prop ]
-            specializer-methods alist>quot
+            [ "specializer" word-prop specialize-quot ]
-        ] if
+        }
-    ] when* ;
+        { [ t ] [ drop ] }
+    } cond ;
 
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;

core/parser/parser.factor

@@ -215,9 +215,6 @@ SYMBOL: in
 : set-in ( name -- )
     check-vocab-string dup in set create-vocab (use+) ;
 
-: create-in ( string -- word )
-    in get create dup set-word dup save-location ;
-
 TUPLE: unexpected want got ;
 
 : unexpected ( want got -- * )
@@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
 : parse-tokens ( end -- seq )
     100 <vector> swap (parse-tokens) >array ;
 
+: create-in ( string -- word )
+    in get create dup set-word dup save-location ;
+
 : CREATE ( -- word ) scan create-in ;
 
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
+
 : create-class-in ( word -- word )
     in get create
     dup save-class-location
@@ -284,6 +288,12 @@ M: no-word summary
         ] ?if
     ] when ;
 
+: create-method-in ( class generic -- method )
+    create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+    scan-word scan-word create-method-in ;
+
 TUPLE: staging-violation word ;
 
 : staging-violation ( word -- * )
@@ -355,7 +365,9 @@ TUPLE: bad-number ;
 : parse-definition ( -- quot )
     \ ; parse-until >quotation ;
 
-: (:) CREATE dup reset-generic parse-definition ;
+: (:) CREATE-WORD parse-definition ;
+
+: (M:) CREATE-METHOD parse-definition ;
 
 GENERIC: expected>string ( obj -- str )
 

core/slots/slots.factor

@@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> slot-spec
 
 : define-typecheck ( class generic quot -- )
-    over define-simple-generic -rot define-method ;
+    over define-simple-generic
+    >r create-method r> define ;
 
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;

core/syntax/syntax.factor

@@ -97,7 +97,7 @@ IN: bootstrap.syntax
     "parsing" [ word t "parsing" set-word-prop ] define-syntax
 
     "SYMBOL:" [
-        CREATE dup reset-generic define-symbol
+        CREATE-WORD define-symbol
     ] define-syntax
 
     "DEFER:" [
@@ -111,31 +111,26 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "GENERIC:" [
-        CREATE dup reset-word
+        CREATE-GENERIC define-simple-generic
-        define-simple-generic
     ] define-syntax
 
     "GENERIC#" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         scan-word <standard-combination> define-generic
     ] define-syntax
 
     "MATH:" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         T{ math-combination } define-generic
     ] define-syntax
 
     "HOOK:" [
-        CREATE dup reset-word scan-word
+        CREATE-GENERIC scan-word
         <hook-combination> define-generic
     ] define-syntax
 
     "M:" [
-        f set-word
+        (M:) define
-        location >r
-        scan-word bootstrap-word scan-word
-        [ parse-definition -rot define-method ] 2keep
-        2array r> remember-definition
     ] define-syntax
 
     "UNION:" [
@@ -163,7 +158,7 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "C:" [
-        CREATE dup reset-generic
+        CREATE-WORD
         scan-word dup check-tuple
         [ construct-boa ] curry define-inline
     ] define-syntax

core/threads/threads-tests.factor

@@ -14,3 +14,5 @@ yield
 [ 3 ] [
     [ 3 swap resume-with ] "Test suspend" suspend
 ] unit-test
+
+[ f ] [ f get-global ] unit-test

core/threads/threads.factor

@@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
 
 : threads 41 getenv ;
 
-threads global [ H{ } assoc-like ] change-at
-
 : thread ( id -- thread ) threads at ;
 
 : thread-registered? ( thread -- ? )

core/tuples/tuples-docs.factor

@@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
 $nl
 "A shortcut for defining BOA constructors:"
 { $subsection POSTPONE: C: }
+"Examples of constructors:"
+{ $code
+    "TUPLE: color red green blue alpha ;"
+    ""
+    "C: <rgba> rgba"
+    ": <rgba> color construct-boa ; ! identical to above"
+    ""
+    ": <rgb>"
+    "    { set-color-red set-color-green set-color-blue }"
+    "    color construct ;"
+    ": <rgb> f <rgba> ; ! identical to above"
+    ""
+    ": <color> construct-empty ;"
+    ": <color> { } color construct ; ! identical to above"
+    ": <color> f f f f <rgba> ; ! identical to above"
+}
 "After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
 
 ARTICLE: "tuple-delegation" "Delegation"
@@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
 "Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
 { $subsection POSTPONE: TUPLE: }
 "An example:"
-{ $code "TUPLE: person name address phone ;" }
+{ $code "TUPLE: person name address phone ;" "C: <person> person" }
-"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
+"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
 { $table
     { "Reader" "Writer" }
     { { $snippet "person-name" }    { $snippet "set-person-name" }    }

core/words/words.factor

@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
 : crossref? ( word -- ? )
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method-def" word-prop ] [ t ] }
+        { [ dup "method-generic" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;

extra/bootstrap/tools/tools.factor

@@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
     "tools.threads"
     "tools.vocabs"
     "tools.vocabs.browser"
+    "tools.vocabs.monitor"
     "editors"
 } [ require ] each

extra/builder/benchmark/benchmark.factor

@@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
 
 IN: builder.benchmark
 
-: passing-benchmarks ( table -- table )
+! : passing-benchmarks ( table -- table )
-  [ second first2 number? swap number? and ] subset ;
+!   [ second first2 number? swap number? and ] subset ;
 
-: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+
+! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
 
 : benchmark-difference ( old-table benchmark-result -- result-diff )
   first2 >r
@@ -17,7 +19,7 @@ IN: builder.benchmark
   2array ;
 
 : compare-tables ( old new -- table )
-  [ passing-benchmarks simplify-table ] 2apply
+  [ passing-benchmarks ] 2apply
   [ benchmark-difference ] with map ;
 
 : benchmark-deltas ( -- table )

extra/delegate/delegate.factor

@@ -7,7 +7,7 @@ IN: delegate
     swap { } like "protocol-words" set-word-prop ;
 
 : PROTOCOL:
-    CREATE dup reset-generic dup define-symbol
+    CREATE-WORD dup define-symbol
     parse-definition swap define-protocol ; parsing
 
 PREDICATE: word protocol "protocol-words" word-prop ;

extra/help/help-tests.factor

@@ -0,0 +1,5 @@
+IN: help.tests
+USING: tools.test help kernel ;
+
+[ 3 throw ] must-fail
+[ ] [ :help ] unit-test

extra/help/help.factor

@@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
     ":edit - jump to source location (parse errors only)" print
 
     ":get  ( var -- value ) accesses variables at time of the error" print
-    ":vars - list all variables at error time";
+    ":vars - list all variables at error time" print ;
 
 : :help ( -- )
     error get delegates [ error-help ] map [ ] subset

extra/io/unix/unix.factor

@@ -3,5 +3,3 @@ io.unix.launcher io.unix.mmap io.backend
 combinators namespaces system vocabs.loader sequences ;
 
 "io.unix." os append require
-
-"tools.vocabs.monitor" require

extra/io/windows/nt/nt.factor

@@ -13,5 +13,3 @@ USE: io.windows.files
 USE: io.backend
 
 T{ windows-nt-io } set-io-backend
-
-"tools.vocabs.monitor" require

extra/locals/locals-tests.factor

@@ -1,5 +1,6 @@
 USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays strings prettyprint ;
+namespaces arrays strings prettyprint io.streams.string parser
+;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 [ "[| a! | ]" ] [
     [| a! | ] unparse
 ] unit-test
+
+DEFER: xyzzy
+
+[ ] [
+    "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
+    <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 10 ] [ 10 xyzzy ] unit-test
+
+[ ] [
+    "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
+    <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 5 ] [ 10 xyzzy ] unit-test

extra/locals/locals.factor

@@ -249,13 +249,14 @@ M: wlet local-rewrite*
     word [ over "declared-effect" set-word-prop ] when*
     effect-in make-locals ;
 
-: ((::)) ( word -- word quot )
+: parse-locals-definition ( word -- word quot )
     scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
     2dup "lambda" set-word-prop
     lambda-rewrite first ;
 
-: (::) ( -- word quot )
+: (::) CREATE-WORD parse-locals-definition ;
-    CREATE dup reset-generic ((::)) ;
+
+: (M::) CREATE-METHOD parse-locals-definition ;
 
 PRIVATE>
 
@@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 
 : :: (::) define ; parsing
 
-! This will be cleaned up when method tuples and method words
+: M:: (M::) define ; parsing
-! are unified
-: create-method ( class generic -- method )
-    2dup method dup
-    [ 2nip ]
-    [ drop 2dup [ ] -rot define-method create-method ] if ;
-
-: CREATE-METHOD ( -- class generic body )
-    scan-word bootstrap-word scan-word 2dup
-    create-method f set-word dup save-location ;
-
-: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
 
 : MACRO:: (::) define-macro ; parsing
 

extra/logging/logging.factor

@@ -127,8 +127,7 @@ PRIVATE>
 
 : LOG:
     #! Syntax: name level
-    CREATE
+    CREATE-WORD
-    dup reset-generic
     dup scan-word
     [ >r >r 1array stack>message r> r> log-message ] 2curry
     define ; parsing

extra/memoize/memoize.factor

@@ -40,7 +40,7 @@ IN: memoize
     over make-memoizer define ;
 
 : MEMO:
-    CREATE dup reset-generic parse-definition define-memoized ; parsing
+    CREATE-WORD parse-definition define-memoized ; parsing
 
 PREDICATE: word memoized "memoize" word-prop ;
 

extra/multiline/multiline.factor

@@ -18,7 +18,7 @@ IN: multiline
     lexer get next-line ;
 
 : STRING:
-    CREATE dup reset-generic
+    CREATE-WORD
     parse-here 1quotation define-inline ; parsing
 
 : (parse-multiline-string) ( start-index end-text -- end-index )

extra/opengl/gl/gl-docs.factor

@@ -5,7 +5,8 @@ IN: opengl.gl
 
 ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
   { $subsection "opengl-specifying-vertices" }
-  { $subsection "opengl-geometric-primitives" } ;  
+  { $subsection "opengl-geometric-primitives" }
+  { $subsection "opengl-modeling-transformations" } ;
 
 ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
 
@@ -68,3 +69,17 @@ HELP: glPolygonMode
                          { $link GL_POINT }
                          { $link GL_LINE }
                          { $link GL_FILL } } } } } ;
+
+ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+  { $subsection glTranslatef }
+  { $subsection glTranslated }
+  { $subsection glRotatef }
+  { $subsection glRotated }
+  { $subsection glScalef }
+  { $subsection glScaled } ;
+
+
+{ glTranslatef glTranslated glRotatef glRotated glScalef glScaled }
+related-words
+
+

extra/openssl/libcrypto/libcrypto.factor

@@ -11,7 +11,7 @@ IN: openssl.libcrypto
 
 <<
 "libcrypto" {
-    { [ win32? ]  [ "libeay32.dll" "stdcall" ] }
+    { [ win32? ]  [ "libeay32.dll" "cdecl" ] }
     { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
     { [ unix? ]   [ "libcrypto.so" "cdecl" ] }
 } cond add-library

extra/openssl/libssl/libssl.factor

@@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ;
 IN: openssl.libssl
 
 << "libssl" {
-    { [ win32? ]  [ "ssleay32.dll" "stdcall" ] }
+    { [ win32? ]  [ "ssleay32.dll" "cdecl" ] }
     { [ macosx? ] [ "libssl.dylib" "cdecl" ] }
     { [ unix? ]   [ "libssl.so" "cdecl" ] }
 } cond add-library >>

extra/promises/promises.factor

@@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ;
   ] [ ] make ;
 
 : LAZY:
-  CREATE dup reset-generic
+  CREATE-WORD
   dup parse-definition
   make-lazy-quot define ; parsing

extra/tools/deploy/shaker/shaker.factor

@@ -133,9 +133,10 @@ IN: tools.deploy.shaker
         strip-io? [ io.backend:io-backend , ] when
 
         [
-            io.backend:io-backend
+            io.backend:io-backend ,
             "default-buffer-size" "io.nonblocking" lookup ,
-        ] { "alarms" "io" "tools" } strip-vocab-globals %
+        ] { } make
+        { "alarms" "io" "tools" } strip-vocab-globals %
 
         strip-dictionary? [
             { } { "cpu" } strip-vocab-globals %
@@ -193,7 +194,7 @@ IN: tools.deploy.shaker
         global swap
         '[ drop , member? not ] assoc-subset
         [ drop string? not ] assoc-subset ! strip CLI args
-        dup keys .
+        dup keys unparse show
         21 setenv
     ] [ drop ] if ;
 

extra/ui/freetype/freetype.factor

@@ -73,10 +73,7 @@ M: freetype-renderer free-fonts ( world -- )
     ] keep *void* ;
 
 : open-face ( font style -- face )
-    ttf-name ttf-path
+    ttf-name ttf-path malloc-file-contents (open-face) ;
-    dup malloc-file-contents
-    swap file-info file-info-size
-    (open-face) ;
 
 SYMBOL: dpi
 

extra/ui/windows/windows.factor

@@ -376,6 +376,22 @@ SYMBOL: trace-messages?
 
 : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
 
+! ! ! !
+: set-world-dim ( dim world -- )
+    swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
+    SetWindowPos drop ;
+USE: random
+USE: arrays
+
+: twiddle
+    100 500 random +
+    100 500 random +
+    2array
+    "x" get-global find-world
+    set-world-dim
+    yield ;
+! ! ! !
+
 : event-loop ( msg -- )
     {
         { [ windows get empty? ] [ drop ] }
@@ -436,17 +452,16 @@ SYMBOL: trace-messages?
 
 : init-win32-ui ( -- )
     V{ } clone nc-buttons set-global
-    "MSG" <c-object> msg-obj set-global
+    "MSG" malloc-object msg-obj set-global
     "Factor-window" malloc-u16-string class-name-ptr set-global
     register-wndclassex drop
     GetDoubleClickTime double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
-    class-name-ptr get-global [
+    class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
-        dup f UnregisterClass drop
+    msg-obj get-global [ free ] when*
-        free
+    f class-name-ptr set-global
-    ] when*
+    f msg-obj set-global ;
-    f class-name-ptr set-global ;
 
 : setup-pixel-format ( hdc -- )
     16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep

extra/unicode/data/data.factor

@@ -5,7 +5,7 @@ IN: unicode.data
 
 <<
 : VALUE:
-    CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
+    CREATE-WORD { f } clone [ first ] curry define ; parsing
 
 : set-value ( value word -- )
     word-def first set-first ;

extra/windows/user32/user32.factor

@@ -1283,7 +1283,13 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
 ! FUNCTION: SetWindowLongA
 ! FUNCTION: SetWindowLongW
 ! FUNCTION: SetWindowPlacement
-! FUNCTION: SetWindowPos
+FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
+
+: HWND_BOTTOM ALIEN: 1 ;
+: HWND_NOTOPMOST ALIEN: -2 ;
+: HWND_TOP ALIEN: 0 ;
+: HWND_TOPMOST ALIEN: -1 ;
+
 ! FUNCTION: SetWindowRgn
 ! FUNCTION: SetWindowsHookA
 ! FUNCTION: SetWindowsHookExA

misc/factor.el

@@ -158,6 +158,11 @@
       (insert str)
       (comint-send-input))))
 
+(defun factor-send-definition ()
+  (interactive)
+  (factor-send-region (search-backward ":")
+                      (search-forward  ";")))
+
 (defun factor-see ()
   (interactive)
   (comint-send-string "*factor*" "\\ ")
@@ -187,6 +192,7 @@
 
 (define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
 (define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
+(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
 (define-key factor-mode-map "\C-c\C-s" 'factor-see)
 (define-key factor-mode-map "\C-ce"    'factor-edit)
 (define-key factor-mode-map "\C-c\C-h" 'factor-help)
@@ -212,3 +218,5 @@
 (defun factor-refresh-all ()
   (interactive)
   (comint-send-string "*factor*" "refresh-all\n"))
+
+

vm/code_gc.c

@@ -375,6 +375,8 @@ void forward_object_xts(void)
 			F_WORD *word = untag_object(obj);
 
 			word->code = forward_xt(word->code);
+			if(word->profiling)
+				word->profiling = forward_xt(word->profiling);
 		}
 		else if(type_of(obj) == QUOTATION_TYPE)
 		{

vm/data_gc.h

@@ -263,13 +263,18 @@ DEFPUSHPOP(root_,extra_roots)
 #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
 #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
 
+INLINE bool in_data_heap_p(CELL ptr)
+{
+	return (ptr >= data_heap->segment->start
+		&& ptr <= data_heap->segment->end);
+}
+
 /* We ignore strings which point outside the data heap, but we might be given
 a char* which points inside the data heap, in which case it is a root, for
 example if we call unbox_char_string() the result is placed in a byte array */
 INLINE bool root_push_alien(const void *ptr)
 {
-	if((CELL)ptr > data_heap->segment->start
+	if(in_data_heap_p((CELL)ptr))
-		&& (CELL)ptr < data_heap->segment->end)
 	{
 		F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
 		if(objptr->header == tag_header(BYTE_ARRAY_TYPE))