From 20ed8ab9a2074caf486ee0f9ee4c2069041ff599 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:17:05 -0500 Subject: [PATCH 01/13] Fix code heap compaction bug --- vm/code_gc.c | 2 ++ vm/data_gc.h | 9 +++++++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/vm/code_gc.c b/vm/code_gc.c index 5c51fe7e8b..5b0d2ebabb 100755 --- a/vm/code_gc.c +++ b/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) { diff --git a/vm/data_gc.h b/vm/data_gc.h index d9c3d8eb1c..8f93ce79a1 100755 --- a/vm/data_gc.h +++ b/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 - && (CELL)ptr < data_heap->segment->end) + if(in_data_heap_p((CELL)ptr)) { F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1; if(objptr->header == tag_header(BYTE_ARRAY_TYPE)) From ae480fb329f686e16642cfcc03384fa3ba6c7cc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:17:32 -0500 Subject: [PATCH 02/13] SetWindowPos --- extra/windows/user32/user32.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor index 39879bf91d..e3e8a23ca7 100755 --- a/extra/windows/user32/user32.factor +++ b/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 From d0687751ed4fa9838ecfd509d3327560ba787213 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:18:05 -0500 Subject: [PATCH 03/13] Fix Windows UI memory corruption --- extra/ui/windows/windows.factor | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 8eb5fe59aa..0c9c23cf76 100755 --- a/extra/ui/windows/windows.factor +++ b/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" 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 [ - dup f UnregisterClass drop - free - ] when* - f class-name-ptr set-global ; + class-name-ptr get-global [ dup f UnregisterClass drop free ] when* + msg-obj get-global [ free ] when* + f class-name-ptr set-global + f msg-obj set-global ; : setup-pixel-format ( hdc -- ) 16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep From 194b0d827efa8e2dc7e35c2beb42d1f77b8ebea8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:18:28 -0500 Subject: [PATCH 04/13] Clarify docs for constructors --- core/tuples/tuples-docs.factor | 20 ++++++++++++++++++-- 1 file changed, 18 insertions(+), 2 deletions(-) diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor index c03b9784ee..3af7d27d86 100755 --- a/core/tuples/tuples-docs.factor +++ b/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" + ": color construct-boa ; ! identical to above" + "" + ": " + " { set-color-red set-color-green set-color-blue }" + " color construct ;" + ": f ; ! identical to above" + "" + ": construct-empty ;" + ": { } color construct ; ! identical to above" + ": f f f f ; ! 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 ;" } -"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:" +{ $code "TUPLE: person name address phone ;" "C: person" } +"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "" } ", and the following reader/writer words:" { $table { "Reader" "Writer" } { { $snippet "person-name" } { $snippet "set-person-name" } } From 91f4dadea80b2cce376d68c0630d96498e916b61 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 00:19:04 -0500 Subject: [PATCH 05/13] Fix openssl binding on Windows --- extra/openssl/libcrypto/libcrypto.factor | 2 +- extra/openssl/libssl/libssl.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/openssl/libssl/libssl.factor diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor index bc65f72435..d06afdc5ea 100755 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/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 diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor old mode 100644 new mode 100755 index d8709cbf53..11dcee31f6 --- a/extra/openssl/libssl/libssl.factor +++ b/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 >> From 8b956d1efa50f8df464c864d30f540adad489d14 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:21:51 -0500 Subject: [PATCH 06/13] Fixing deployment --- core/alien/c-types/c-types.factor | 4 ++-- core/io/files/files.factor | 5 +---- core/io/io.factor | 8 +++++--- extra/bootstrap/tools/tools.factor | 1 + extra/io/unix/unix.factor | 2 -- extra/io/windows/nt/nt.factor | 2 -- extra/tools/deploy/shaker/shaker.factor | 7 ++++--- extra/ui/freetype/freetype.factor | 5 +---- 8 files changed, 14 insertions(+), 20 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index c3f5c64b29..f1d8abdc1e 100755 --- a/core/alien/c-types/c-types.factor +++ b/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 ) - binary file-contents malloc-byte-array ; +: malloc-file-contents ( path -- alien len ) + binary file-contents dup malloc-byte-array swap length ; [ [ alien-cell ] diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 18cdbd3791..5de86d0baa 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -222,10 +222,7 @@ M: pathname <=> [ pathname-string ] compare ; >r r> with-stream ; inline : file-contents ( path encoding -- str ) - dupd [ file-info file-info-size read ] with-file-reader ; - -! : file-contents ( path encoding -- str ) -! dupd [ file-length read ] with-file-reader ; + contents ; : with-file-writer ( path encoding quot -- ) >r r> with-stream ; inline diff --git a/core/io/io.factor b/core/io/io.factor index 2d927d088a..ef9eae7902 100755 --- a/core/io/io.factor +++ b/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 - continuations assocs io.styles sbufs ; +USING: hashtables generic kernel math namespaces sequences +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 [ stream-copy ] keep >string ; + [ + [ 65536 read dup ] [ ] [ drop ] unfold concat f like + ] with-stream ; diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor index 0bf7a032ee..670bca4903 100755 --- a/extra/bootstrap/tools/tools.factor +++ b/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 diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor index 01e29866eb..1f0492a060 100755 --- a/extra/io/unix/unix.factor +++ b/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 diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 319acc35f8..1baec5658f 100755 --- a/extra/io/windows/nt/nt.factor +++ b/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 diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index edf78de479..44fb15ac7e 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/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 ; diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 8dca72c29e..e9527e6f9a 100755 --- a/extra/ui/freetype/freetype.factor +++ b/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 - dup malloc-file-contents - swap file-info file-info-size - (open-face) ; + ttf-name ttf-path malloc-file-contents (open-face) ; SYMBOL: dpi From ec698b7f53fbd5af40a5eef170eb0dc93e243e5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:43:00 -0500 Subject: [PATCH 07/13] Parser overhaul --- core/debugger/debugger.factor | 2 +- core/generic/generic-docs.factor | 13 ++--- core/generic/generic.factor | 54 +++++++------------ core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 4 -- .../specializers/specializers.factor | 36 ++++++++++--- core/parser/parser.factor | 20 +++++-- core/slots/slots.factor | 3 +- core/syntax/syntax.factor | 19 +++---- core/words/words.factor | 2 +- extra/delegate/delegate.factor | 2 +- extra/locals/locals-tests.factor | 19 ++++++- extra/locals/locals.factor | 20 ++----- extra/memoize/memoize.factor | 2 +- extra/multiline/multiline.factor | 2 +- extra/promises/promises.factor | 2 +- extra/unicode/data/data.factor | 2 +- 17 files changed, 111 insertions(+), 93 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 40bcbe78b1..ad2fa14954 100755 --- a/core/debugger/debugger.factor +++ b/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" ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9b799d9143..62b85dde3a 100755 --- a/core/generic/generic-docs.factor +++ b/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: { $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 -{ $values { "quot" quotation } { "class" class } { "generic" generic } } -{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; +HELP: create-method +{ $values { "class" class } { "generic" generic } { "method" method-body } } +{ $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" } } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3c83b87d49..ad31831e94 100755 --- a/core/generic/generic.factor +++ b/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 ) - "combination" word-prop method-prologue swap append ; - -PREDICATE: word method-body "method-def" word-prop >boolean ; +PREDICATE: word method-body + "method-generic" 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 ; -: ( quot class generic -- method ) +: ( class generic -- method ) check-method - [ make-method-def ] 3keep [ method-word-props ] 2keep method-word-name f - tuck set-word-props - dup rot define ; + [ set-word-props ] keep ; -: redefine-method ( quot class generic -- ) - [ method swap "method-def" set-word-prop ] 3keep - [ make-method-def ] 2keep - method swap define ; +: reveal-method ( method class generic -- ) + [ set-at ] with-methods ; -: define-method ( quot class generic -- ) - >r bootstrap-word r> - 2dup method [ - redefine-method +: create-method ( class generic -- method ) + 2dup method dup [ + 2nip ] [ - [ ] 2keep - [ set-at ] with-methods + drop [ dup ] 2keep reveal-method ] if ; +: ( generic combination -- method ) + object bootstrap-word pick + [ -rot make-default-method define ] keep ; + : define-default-method ( generic combination -- ) - dupd make-default-method object bootstrap-word pick - "default-method" set-word-prop ; + dupd "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 - [ "method-def" word-prop ] when ; + first2 method definition ; : 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 diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 27b0ddb7a2..9fd5481a39 100755 --- a/core/generic/math/math.factor +++ b/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 ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 313f487c99..c634e02e75 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,10 +8,6 @@ IN: generic.standard TUPLE: standard-combination # ; -M: standard-combination method-prologue - standard-combination-# object - swap add* [ declare ] curry ; - C: standard-combination SYMBOL: (dispatch#) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 10a9fda3ea..5153d84c7f 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/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 + 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 { number } = [ - drop tag-specializer - ] [ - specializer-methods alist>quot - ] if - ] when* ; + dup word-def swap { + { [ dup standard-method? ] [ specialize-method ] } + { + [ dup "specializer" word-prop ] + [ "specializer" word-prop specialize-quot ] + } + { [ t ] [ drop ] } + } cond ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 50f8f582d3..c955817ab9 100755 --- a/core/parser/parser.factor +++ b/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 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 ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 92d22247bd..7e9046573f 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ; C: 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 ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 79a5553228..d9870b08da 100755 --- a/core/syntax/syntax.factor +++ b/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 - define-simple-generic + CREATE-GENERIC define-simple-generic ] define-syntax "GENERIC#" [ - CREATE dup reset-word + CREATE-GENERIC scan-word 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 define-generic ] define-syntax "M:" [ - f set-word - location >r - scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep - 2array r> remember-definition + (M:) define ] 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 diff --git a/core/words/words.factor b/core/words/words.factor index ce69c1ff2e..73b877fdbb 100755 --- a/core/words/words.factor +++ b/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 ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 654d096b26..9eabfae95c 100755 --- a/extra/delegate/delegate.factor +++ b/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 ; diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index b4f1b0a61e..bd1e62f22a 100755 --- a/extra/locals/locals-tests.factor +++ b/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 ;" + "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 ;" + "lambda-generic-test" parse-stream drop +] unit-test + +[ 5 ] [ 10 xyzzy ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 9819e65e37..a8f5e139e7 100755 --- a/extra/locals/locals.factor +++ b/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) 2dup "lambda" set-word-prop lambda-rewrite first ; -: (::) ( -- word quot ) - CREATE dup reset-generic ((::)) ; +: (::) CREATE-WORD parse-locals-definition ; + +: (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 -! 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 +: M:: (M::) define ; parsing : MACRO:: (::) define-macro ; parsing diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 3b0b8fd29f..ab915ae7d5 100755 --- a/extra/memoize/memoize.factor +++ b/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 ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index 5baa205d15..079f484274 100755 --- a/extra/multiline/multiline.factor +++ b/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 ) diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 3724b929f0..469f6a91ed 100755 --- a/extra/promises/promises.factor +++ b/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 diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 11be803893..d8e1e8937a 100755 --- a/extra/unicode/data/data.factor +++ b/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 ; From bc71849bf665e071a291bfdfbdee9ca031193b86 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:44:17 -0500 Subject: [PATCH 08/13] Fix bogus f variable in global namespace --- core/threads/threads-tests.factor | 2 ++ core/threads/threads.factor | 2 -- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index c2e627e7bf..d746404cba 100755 --- a/core/threads/threads-tests.factor +++ b/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 diff --git a/core/threads/threads.factor b/core/threads/threads.factor index b4fd6eee60..d7d7988893 100755 --- a/core/threads/threads.factor +++ b/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 -- ? ) From d06db3f628693ad5d40933cb6ca8b8bf056ba24d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:44:39 -0500 Subject: [PATCH 09/13] Fix bootstrap error exit code --- core/bootstrap/stage1.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 0e038d0a10..74b4d03cbb 100755 --- a/core/bootstrap/stage1.factor +++ b/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 From 7d3c590cfe1a35437d8236629d46bce154f3b24a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 02:45:45 -0500 Subject: [PATCH 10/13] Update logging for parser change --- extra/logging/logging.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 5846515dca..42545500a5 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -127,8 +127,7 @@ PRIVATE> : LOG: #! Syntax: name level - CREATE - dup reset-generic + CREATE-WORD dup scan-word [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing From 254d8455a3875d80e4d9328b98292a5892c32361 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 03:43:24 -0500 Subject: [PATCH 11/13] load-library returns f if library not defined --- core/alien/alien-docs.factor | 3 +-- core/alien/alien.factor | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 475cf72d28..95b29ee50b 100755 --- a/core/alien/alien-docs.factor +++ b/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." } -{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ; +{ $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." } ; HELP: add-library { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } } diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 0369d55fb3..bce2e16d73 100755 --- a/core/alien/alien.factor +++ b/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 -- ) swap libraries get set-at ; From 4a4eb8b7bb59f9528ebed001c2cdd136680361f6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 03:43:30 -0500 Subject: [PATCH 12/13] Fix :help --- extra/help/help-tests.factor | 5 +++++ extra/help/help.factor | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) create mode 100644 extra/help/help-tests.factor diff --git a/extra/help/help-tests.factor b/extra/help/help-tests.factor new file mode 100644 index 0000000000..e38f2fc15d --- /dev/null +++ b/extra/help/help-tests.factor @@ -0,0 +1,5 @@ +IN: help.tests +USING: tools.test help kernel ; + +[ 3 throw ] must-fail +[ ] [ :help ] unit-test diff --git a/extra/help/help.factor b/extra/help/help.factor index 85f5a35a5c..34e90b2ccf 100755 --- a/extra/help/help.factor +++ b/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 From 8a8a94206d62abdf8f36ff2c26384ed39c65e646 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 16 Mar 2008 03:51:43 -0500 Subject: [PATCH 13/13] Update unit tests --- core/definitions/definitions-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 4e8fb255dd..ebbce4d7e2 100755 --- a/core/definitions/definitions-tests.factor +++ b/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 [ ] [