diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index a91fccfea8..d8d834de46 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,5 +1,6 @@ - nodes: lazily create history, class/literal map hashes -- write tests for callcc and catch inference +- 5 car gives wrong error +- compile interruption checks + ui: diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 6a6013e75a..5419182e05 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -64,8 +64,8 @@ sequences io vectors words ; "/library/words.factor" "/library/vocabularies.factor" - "/library/errors.factor" "/library/continuations.factor" + "/library/errors.factor" "/library/styles.factor" "/library/io/stream.factor" diff --git a/library/continuations.factor b/library/continuations.factor index 1cb685dff9..841d20c675 100644 --- a/library/continuations.factor +++ b/library/continuations.factor @@ -1,7 +1,13 @@ ! Copyright (C) 2003, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. +IN: errors +USING: kernel-internals ; + +: catchstack ( -- cs ) 6 getenv ; +: set-catchstack ( cs -- ) 6 setenv ; + IN: kernel -USING: arrays errors lists namespaces sequences words vectors ; +USING: namespaces sequences ; TUPLE: continuation data c call name catch ; @@ -26,6 +32,32 @@ TUPLE: continuation data c call name catch ; [ continuation-name ] keep continuation-catch ; inline +: ifcc ( terminator balance -- | quot: continuation -- ) + [ + t continuation + dup continuation-data dup pop* f swap push + swap >r -rot r> + ] call -rot ifte ; inline + +: infer-only ( quot -- ) + #! For stack effect inference, pretend the quotation is + #! there, but ignore it during execution. + drop ; + +: (callcc0) ( -- ) [ drop ] infer-only ; inline + +: (callcc1) ( -- value ) (callcc0) 9 getenv ; inline + +: callcc1 ( quot -- | quot: continuation -- ) + #! Call a quotation with the current continuation, which may + #! be restored using continue-with. + [ (callcc1) ] ifcc ; inline + +: callcc0 ( quot -- | quot: continuation -- ) + #! Call a quotation with the current continuation, which may + #! be restored using continue-with. + [ (callcc0) ] ifcc ; inline + : continue ( continuation -- ) #! Restore a continuation. >continuation< set-catchstack set-namestack set-callstack @@ -34,26 +66,4 @@ TUPLE: continuation data c call name catch ; : continue-with ( object continuation -- object ) #! Restore a continuation, and place the object in the #! restored data stack. - >continuation< set-catchstack set-namestack set-callstack - >r swap >r set-datastack r> r> set-c-stack ; - -: (callcc) ( terminator balance -- | quot: continuation -- ) - #! Direct calls to this word will not compile correctly; - #! use callcc0 or callcc1 to declare continuation arity - #! instead. The terminator branch always executes. It might - #! contain a call to 'continue', which ends control flow. - #! The balance branch is never called, but it is there to - #! give the callcc form a stack effect. - >r >r - continuation dup continuation-call dup pop* pop* - t r> r> ifte ; inline - -: callcc0 ( quot -- | quot: continuation -- ) - #! Call a quotation with the current continuation, which may - #! be restored using continue. - [ drop ] (callcc) ; inline - -: callcc1 ( quot -- | quot: continuation -- ) - #! Call a quotation with the current continuation, which may - #! be restored using continue-with. - [ ] (callcc) ; inline + swap 9 setenv continue ; inline diff --git a/library/errors.factor b/library/errors.factor index e49d99d70f..f5b555dc89 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -1,11 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. -IN: kernel -DEFER: callcc1 -DEFER: continue-with - IN: errors -USING: kernel-internals lists sequences ; +USING: kernel kernel-internals lists sequences ; ! This is a very lightweight exception handling system. @@ -13,9 +9,6 @@ TUPLE: no-method object generic ; : no-method ( object generic -- ) throw ; -: catchstack ( -- cs ) 6 getenv ; -: set-catchstack ( cs -- ) 6 setenv ; - : >c ( catch -- ) catchstack cons set-catchstack ; : c> ( catch -- ) catchstack uncons set-catchstack ; @@ -28,25 +21,23 @@ TUPLE: no-method object generic ; : rethrow ( error -- ) #! Use rethrow when passing an error on from a catch block. - catchstack empty? [ - die "Can't happen" throw - ] [ - c> continue-with - ] ifte ; + catchstack empty? + [ die "Can't happen" throw ] [ c> continue-with ] ifte ; : cleanup ( try cleanup -- | try: -- | cleanup: -- ) #! Call the try quotation. If an exception is thrown in the #! dynamic extent of the quotation, restore the datastack #! and run the cleanup quotation. Then throw the error to #! the next outermost catch handler. - >r [ dup slip ] catch nip r> - swap slip [ rethrow ] when* ; inline + [ >c >r call c> drop r> call ] + [ (callcc1) >r nip call r> rethrow ] ifcc ; inline : recover ( try recovery -- | try: -- | recovery: error -- ) #! Call the try quotation. If an exception is thrown in the #! dynamic extent of the quotation, restore the datastack, #! push the exception on the datastack, and call the #! recovery quotation. - >r catch r> when* ; inline + [ >c drop call c> drop ] + [ (callcc1) rot drop swap call ] ifcc ; inline GENERIC: error. ( error -- ) diff --git a/library/httpd/browser-responder.factor b/library/httpd/browser-responder.factor index 7ed69bd555..6ffcd1f5f1 100644 --- a/library/httpd/browser-responder.factor +++ b/library/httpd/browser-responder.factor @@ -42,14 +42,14 @@ USING: html cont-responder kernel io namespaces words lists prettyprint : vocab-list ( vocab -- ) #! Write out the HTML for the list of vocabularies. Make the currently #! selected vocab be 'vocab'. - vocabs [ over swap option ] each drop ; : word-list ( vocab word -- ) #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item #! the currently selected option. - swap words [ word-name over swap option ] each drop ; @@ -65,16 +65,16 @@ USING: html cont-responder kernel io namespaces words lists prettyprint : browser-body ( vocab word -- ) #! Write out the HTML for the body of the main browser page. - +
- - - + + + - - - + + +
"Vocabularies" write "Words" write "Source" write "Vocabularies" write "Words" write "Source" write
over vocab-list 2dup word-list word-source over vocab-list 2dup word-list word-source
vm-statistics ; @@ -104,7 +104,7 @@ USING: html cont-responder kernel io namespaces words lists prettyprint 2dup browser-title browser-style -
browser-body
+
browser-body
] show-final ; diff --git a/library/httpd/cont-responder.factor b/library/httpd/cont-responder.factor index b89c0b5155..35e2619bdb 100644 --- a/library/httpd/cont-responder.factor +++ b/library/httpd/cont-responder.factor @@ -286,7 +286,7 @@ SYMBOL: root-continuation #! back to the most recent 'show' call (via the callback-cc). #! The text of the link will be the 'text' argument on the #! stack. - url a> write ; + url a> write ; : init-session-namespace ( -- ) #! Setup the initial session namespace. Currently this only @@ -340,7 +340,7 @@ SYMBOL: root-continuation [ "Press OK to Continue" [ swap paragraph - "OK" write + "OK" write ] simple-page ] show 2drop ; @@ -353,12 +353,12 @@ SYMBOL: root-continuation : horizontal-layout ( list -- ) #! Given a list of HTML components, arrange them horizontally. - [ ] each + [ ] each
call
call
; : button ( label -- ) #! Output an HTML submit button with the given label. - ; + ; : with-simple-html-output ( quot -- ) #! Run the quotation inside an HTML stream wrapped diff --git a/library/httpd/html-tags.factor b/library/httpd/html-tags.factor index 1e697d1acd..a449bb36b1 100644 --- a/library/httpd/html-tags.factor +++ b/library/httpd/html-tags.factor @@ -42,18 +42,16 @@ USE: sequences ! !

"someoutput" write

! -!

will outupt the opening tag and

will output the closing +!

will output the opening tag and

will output the closing ! tag with no attributes. ! -!

"someoutput" write

+!

"someoutput" write

! ! This time the opening tag does not have the '>'. It pushes ! a namespace on the stack to hold the attributes and values. ! Any attribute words used will store the attribute and values -! in that namespace. After the attribute word should come the -! value of that attribute. The next attribute word or -! finishing word (which is the html word followed by '>') -! will actually set the attribute to that value in the namespace. +! in that namespace. Before the attribute word should come the +! value of that attribute. ! The finishing word will print out the operning tag including ! attributes. ! Any writes after this will appear after the opening tag. @@ -62,17 +60,17 @@ USE: sequences ! operations: ! ! (url -- ) -! "Click me" write +! "Click me" write ! ! (url -- ) -! "click" write +! "click" write ! ! (url -- ) -! "click" write +! "click" write ! ! Tags that have no 'closing' equivalent have a trailing tag/> form: ! -! +! : attrs>string ( alist -- string ) #! Convert the attrs alist to a string @@ -85,14 +83,6 @@ USE: sequences #! nothing. "attrs" get attrs>string write ; -: store-prev-attribute ( n: tag value -- ) - #! Assumes an attribute namespace is on the stack. - #! Gets the previous attribute that was used (if any) - #! and sets it's value to the current value on the stack. - #! If there is no previous attribute, no value is expected - #! on the stack. - "current-attribute" get [ swons "attrs" get push ] when* ; - : html-word ( name def -- ) #! Define 'word creating' word to allow #! dynamically creating words. @@ -118,7 +108,7 @@ USE: sequences : foo> ">" append ; -: do-foo> store-prev-attribute write-attributes n> drop ">" write ; +: do-foo> write-attributes n> drop ">" write ; : def-for-html-word-foo> ( name -- ) #! Return the name and code for the foo> patterned @@ -162,8 +152,8 @@ USE: sequences def-for-html-word-foo/> ; : define-attribute-word ( name -- ) - dup "=" append swap [ - \ store-prev-attribute , , [ "current-attribute" set ] % + dup "=" swap append swap [ + , [ swons "attrs" get push ] % ] [ ] make html-word drop ; ! Define some closed HTML tags diff --git a/library/httpd/html.factor b/library/httpd/html.factor index dceb67bbac..ac4bd8577f 100644 --- a/library/httpd/html.factor +++ b/library/httpd/html.factor @@ -55,7 +55,7 @@ presentation sequences strings styles words ; over css-style dup "" = [ drop call ] [ - call + call ] ifte ; : resolve-file-link ( path -- link ) @@ -70,7 +70,7 @@ presentation sequences strings styles words ; : file-link-tag ( style quot -- ) over file swap assoc [ - call + call ] [ call ] ifte* ; @@ -86,7 +86,7 @@ presentation sequences strings styles words ; : browser-link-tag ( style quot -- style ) over presented swap assoc dup word? [ - call + call ] [ drop call ] ifte ; diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index 181d04c07e..4fd9b62900 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -526,3 +526,14 @@ prettyprint ; ] "infer" set-word-prop \ flush-icache [ [ ] [ ] ] "infer-effect" set-word-prop + +\ infer-only [ [ object ] [ ] ] "infer-effect" set-word-prop +\ infer-only [ pop-literal infer-quot-value ] "infer" set-word-prop + +\ (callcc0) [ + "(callcc0) cannot be compiled (yet)" throw +] "infer" set-word-prop + +\ (callcc1) [ + "(callcc1) cannot be compiled (yet)" throw +] "infer" set-word-prop diff --git a/library/sdl/sdl-ttf.factor b/library/sdl/sdl-ttf.factor index 0dbfebc79f..7e7a8df359 100644 --- a/library/sdl/sdl-ttf.factor +++ b/library/sdl/sdl-ttf.factor @@ -9,8 +9,8 @@ USE: alien : TTF_ByteSwappedUNICODE ( swapped -- ) "void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ; -: TTF_Init ( -- ) - "void" "sdl-ttf" "TTF_Init" [ ] alien-invoke ; +: TTF_Init ( -- n ) + "int" "sdl-ttf" "TTF_Init" [ ] alien-invoke ; : TTF_OpenFont ( file ptsize -- font ) "void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ; diff --git a/library/test/continuations.factor b/library/test/continuations.factor index 26af2a5fa2..9e0664e8d3 100644 --- a/library/test/continuations.factor +++ b/library/test/continuations.factor @@ -27,10 +27,3 @@ USE: test [ t ] [ 10 callcc1-test 10 >list = ] unit-test [ t ] [ callcc-namespace-test ] unit-test - -: multishot-test ( -- stack ) - [ - dup "cc" set 5 swap continue-with - ] callcc1 "cc" get continuation-data ; - -[ 5 { } ] [ multishot-test ] unit-test diff --git a/library/test/errors.factor b/library/test/errors.factor index aa8a244b91..97239cd8d5 100644 --- a/library/test/errors.factor +++ b/library/test/errors.factor @@ -26,8 +26,9 @@ USE: memory [ [ "2 car" ] parse ] catch print-error -! This should not raise an error -[ 1 2 3 ] [ 1 2 3 f throw ] unit-test +[ car ] [ [ 5 car ] catch no-method-generic ] unit-test + +[ 1 2 3 ] [ f throw ] unit-test-fails ! See how well callstack overflow is handled : callstack-overflow callstack-overflow f ; diff --git a/library/tools/debugger.factor b/library/tools/debugger.factor index ff39108051..5a84869a11 100644 --- a/library/tools/debugger.factor +++ b/library/tools/debugger.factor @@ -45,24 +45,24 @@ parser prettyprint sequences io strings vectors words ; "User interrupt" print drop ; PREDICATE: cons kernel-error ( obj -- ? ) - car kernel-error = ; + dup first kernel-error = swap second 0 11 between? and ; M: kernel-error error. ( error -- ) #! Kernel errors are indexed by integers. - cdr uncons car swap { - expired-error. - io-error. - undefined-word-error. - type-check-error. - float-format-error. - signal-error. - negative-array-size-error. - c-string-error. - ffi-error. - heap-scan-error. - undefined-symbol-error. - user-interrupt. - } nth execute ; + cdr uncons car swap @{ + [ expired-error. ] + [ io-error. ] + [ undefined-word-error. ] + [ type-check-error. ] + [ float-format-error. ] + [ signal-error. ] + [ negative-array-size-error. ] + [ c-string-error. ] + [ ffi-error. ] + [ heap-scan-error. ] + [ undefined-symbol-error. ] + [ user-interrupt. ] + }@ dispatch ; M: no-method error. ( error -- ) "No suitable method." print diff --git a/library/ui/fonts.factor b/library/ui/fonts.factor index aa1c2cc68b..b080d78920 100644 --- a/library/ui/fonts.factor +++ b/library/ui/fonts.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: gadgets -USING: alien arrays hashtables io kernel lists namespaces sdl -sequences styles ; +USING: alien arrays errors hashtables io kernel lists namespaces +sdl sequences styles ; : ttf-name ( font style -- name ) cons {{ @@ -23,8 +23,9 @@ sequences styles ; : ttf-path ( name -- string ) [ "/fonts/" % % ".ttf" % ] "" make resource-path ; -: open-font ( [ font style ptsize ] -- alien ) - first3 >r ttf-name ttf-path r> TTF_OpenFont ; +: open-font ( { font style ptsize } -- alien ) + first3 >r ttf-name ttf-path r> TTF_OpenFont + dup alien-address 0 = [ SDL_GetError throw ] when ; SYMBOL: open-fonts @@ -34,7 +35,7 @@ SYMBOL: open-fonts global [ open-fonts nest drop ] bind : ttf-init ( -- ) - TTF_Init + TTF_Init -1 = [ SDL_GetError throw ] when global [ open-fonts [ [ cdr expired? not ] hash-subset ] change ] bind ; diff --git a/library/ui/world.factor b/library/ui/world.factor index fbce7f621a..484b8ee93f 100644 --- a/library/ui/world.factor +++ b/library/ui/world.factor @@ -41,11 +41,11 @@ C: world ( -- world ) dup add-layer dup world get set-world-glass dupd add-gadget prefer ; +: world-clip ( -- rect ) + @{ 0 0 0 }@ width get height get 0 3array ; + : draw-world ( world -- ) - [ - @{ 0 0 0 }@ width get height get 0 3array clip set - draw-gadget - ] with-surface ; + [ world-clip clip set draw-gadget ] with-surface ; DEFER: handle-event