redid HTML tags; tweaked continuations to infer properly

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:
 

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"

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
+    swap 9 setenv continue ; inline
-    >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

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 -- ) <no-method> 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? [
+    catchstack empty?
-        die "Can't happen" throw
+    [ die "Can't happen" throw ] [ c> continue-with ] ifte ;
-    ] [
-        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>
+    [ >c >r call c> drop r> call ]
-    swap slip [ rethrow ] when* ; inline
+    [ (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 -- )

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'.
-  <select name= "vocab" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select> 
+  <select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select> 
     vocabs [ over swap option ] each drop
   </select> ;
 
 : word-list ( vocab word -- )
   #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
   #! the currently selected option.
-  <select name= "word" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select> 
+  <select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select> 
     swap words [ word-name over swap option ] each drop
   </select> ;
 
@@ -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.
-  <table width= "100%" table> 
+  <table "100%" =width table> 
     <tr>  
-      <td> "<b>Vocabularies</b>" write </td>
+      <td> <b> "Vocabularies" write </b> </td>
-      <td> "<b>Words</b>" write </td>
+      <td> <b> "Words" write </b> </td>
-      <td> "<b>Source</b>" write </td>
+      <td> <b> "Source" write </b> </td>
     </tr>
     <tr>  
-      <td valign= "top" style= "width: 200" td> over vocab-list </td> 
+      <td "top" =valign "width: 200" =style td> over vocab-list </td> 
-      <td valign= "top" style= "width: 200" td> 2dup word-list </td> 
+      <td "top" =valign "width: 200" =style td> 2dup word-list </td> 
-      <td valign= "top" td> word-source </td> 
+      <td "top" =valign td> word-source </td> 
     </tr>
   </table>
   vm-statistics ;
@@ -104,7 +104,7 @@ USING: html cont-responder kernel io namespaces words lists prettyprint
     <html> 
       <head> 2dup browser-title browser-style </head>
       <body> 
-        <form name= "main" action= "" method= "get" form> browser-body </form>
+        <form "main" =name "" =action "get" =method form> browser-body </form>
       </body>
     </html> 
   ] show-final ;

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.
-  <a href= callback-quot expirable register-continuation id>url a> write </a> ;
+  <a =href callback-quot expirable register-continuation id>url a> write </a> ;
 
 : init-session-namespace ( -- )
   #! Setup the initial session namespace. Currently this only
@@ -340,7 +340,7 @@ SYMBOL: root-continuation
   [
     "Press OK to Continue" [
        swap paragraph 
-       <a href= a> "OK" write </a>
+       <a =href a> "OK" write </a>
     ] simple-page 
   ] show 2drop ;
 
@@ -353,12 +353,12 @@ SYMBOL: root-continuation
 : horizontal-layout ( list -- )
   #! Given a list of HTML components, arrange them horizontally.
   <table> 
-    <tr valign= "top" tr> [ <td> call </td> ] each </tr>
+    <tr "top" =valign tr> [ <td> call </td> ] each </tr>
   </table> ;
 
 : button ( label -- )
   #! Output an HTML submit button with the given label.
-  <input type= "submit" value= input/> ;
+  <input "submit" =type =value input/> ;
 
 : with-simple-html-output ( quot -- )
   #! Run the quotation inside an HTML stream wrapped

library/httpd/html-tags.factor

@@ -42,18 +42,16 @@ USE: sequences
 ! 
 ! <p> "someoutput" write </p>
 !
-! <p> will outupt the opening tag and </p> will output the closing
+! <p> will output the opening tag and </p> will output the closing
 ! tag with no attributes.
 !
-! <p class= "red" p> "someoutput" write </p>
+! <p "red" =class p> "someoutput" write </p>
 !
 ! 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
+! in that namespace. Before the attribute word should come the
-! value of that attribute. The next attribute word or 
+! value of that attribute.
-! finishing word (which is the html word followed by '>') 
-! will actually set the attribute to that value in the namespace.
 ! 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 -- )
-! <a href= a> "Click me" write </a>
+! <a =href a> "Click me" write </a>
 !
 ! (url -- )
-! <a href= "http://" swap append a> "click" write </a>
+! <a "http://" swap append =href a> "click" write </a>
 !
 ! (url -- )
-! <a href= [ "http://" % % ] "" make a> "click" write </a>
+! <a [ "http://" % % ] "" make =href a> "click" write </a>
 !
 ! Tags that have no 'closing' equivalent have a trailing tag/> form:
 !
-! <input type= "text" name= "name" size= "20" input/>
+! <input "text" =type "name" =name "20" =size input/>
 
 : 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 [
+    dup "=" swap append swap [
-        \ store-prev-attribute , , [ "current-attribute" set ] %
+        , [ swons "attrs" get push ] %
     ] [ ] make html-word drop ;
 
 ! Define some closed HTML tags

library/httpd/html.factor

@@ -55,7 +55,7 @@ presentation sequences strings styles words ;
     over css-style dup "" = [
         drop call
     ] [
-        <span style= span> call </span>
+        <span =style span> call </span>
     ] ifte ;
 
 : resolve-file-link ( path -- link )
@@ -70,7 +70,7 @@ presentation sequences strings styles words ;
 
 : file-link-tag ( style quot -- )
     over file swap assoc [
-        <a href= file-link-href a> call </a>
+        <a file-link-href =href a> call </a>
     ] [
         call
     ] ifte* ;
@@ -86,7 +86,7 @@ presentation sequences strings styles words ;
 
 : browser-link-tag ( style quot -- style )
     over presented swap assoc dup word? [
-        <a href= browser-link-href a> call </a>
+        <a browser-link-href =href a> call </a>
     ] [
         drop call
     ] ifte ;

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

library/sdl/sdl-ttf.factor

@@ -9,8 +9,8 @@ USE: alien
 : TTF_ByteSwappedUNICODE ( swapped -- )
     "void" "sdl-ttf" "TTF_ByteSwappedUNICODE" [ "int" ] alien-invoke ;
 
-: TTF_Init ( -- )
+: TTF_Init ( -- n )
-    "void" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
+    "int" "sdl-ttf" "TTF_Init" [ ] alien-invoke ;
 
 : TTF_OpenFont ( file ptsize -- font )
     "void*" "sdl-ttf" "TTF_OpenFont" [ "char*" "int" ] alien-invoke ;

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

library/test/errors.factor

@@ -26,8 +26,9 @@ USE: memory
 
 [ [ "2 car" ] parse ] catch print-error
 
-! This should not raise an error
+[ car ] [ [ 5 car ] catch no-method-generic ] unit-test
-[ 1 2 3 ] [ 1 2 3 f throw ] unit-test
+
+[ 1 2 3 ] [ f throw ] unit-test-fails
 
 ! See how well callstack overflow is handled
 : callstack-overflow callstack-overflow f ;

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 {
+    cdr uncons car swap @{
-        expired-error.
+        [ expired-error. ]
-        io-error.
+        [ io-error. ]
-        undefined-word-error.
+        [ undefined-word-error. ]
-        type-check-error.
+        [ type-check-error. ]
-        float-format-error.
+        [ float-format-error. ]
-        signal-error.
+        [ signal-error. ]
-        negative-array-size-error.
+        [ negative-array-size-error. ]
-        c-string-error.
+        [ c-string-error. ]
-        ffi-error.
+        [ ffi-error. ]
-        heap-scan-error.
+        [ heap-scan-error. ]
-        undefined-symbol-error.
+        [ undefined-symbol-error. ]
-        user-interrupt.
+        [ user-interrupt. ]
-    } nth execute ;
+    }@ dispatch ;
 
 M: no-method error. ( error -- )
     "No suitable method." print

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
+USING: alien arrays errors hashtables io kernel lists namespaces
-sequences styles ;
+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 )
+: open-font ( { font style ptsize } -- alien )
-    first3 >r ttf-name ttf-path r> TTF_OpenFont ;
+    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 ;

library/ui/world.factor

@@ -41,11 +41,11 @@ C: world ( -- world )
     <gadget> 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 <rect> ;
+
 : draw-world ( world -- )
-    [
+    [ world-clip clip set draw-gadget ] with-surface ;
-        @{ 0 0 0 }@ width get height get 0 3array <rect> clip set
-        draw-gadget
-    ] with-surface ;
 
 DEFER: handle-event