work on native factor, httpd now uses catch

TODO.FACTOR.txt

@@ -1,7 +1,6 @@
 + native:
 
 - parsing: HEX:, #\, |
-- minimal use/in for parse-stream
 - prettyprint-1
 - {...} vectors
 - parsing should be parsing
@@ -12,7 +11,6 @@
 - clone-sbuf
 - contains ==> contains?
 - telnetd: send errors on socket
-- native 'see'
 - partition, sort
 - inspector: sort
 
@@ -59,7 +57,6 @@
 
 + httpd:
 
-- use catch
 - httpd: don't flush so much
 - log with date
 - log user agent

library/debugger.factor

@@ -65,7 +65,7 @@ USE: unparser
 
     suspend ;
 
-: :s ( -- ) "error-datastack"  get prettyprint ;
+: :s ( -- ) "error-datastack"  get . ;
-: :r ( -- ) "error-callstack"  get prettyprint ;
+: :r ( -- ) "error-callstack"  get . ;
-: :n ( -- ) "error-namestack"  get prettyprint ;
+: :n ( -- ) "error-namestack"  get . ;
-: :c ( -- ) "error-catchstack" get prettyprint ;
+: :c ( -- ) "error-catchstack" get . ;

library/httpd/httpd.factor

@@ -28,6 +28,7 @@
 IN: httpd
 USE: arithmetic
 USE: combinators
+USE: errors
 USE: lists
 USE: logging
 USE: logic
@@ -73,11 +74,10 @@ USE: url-encoding
     ] ifte ;
 
 : httpd-client ( socket -- )
-    <namespace> [
+    [
-        dup "client" set "stdio" set
+        "stdio" get "client" set log-client
-        log-client
         read [ httpd-request ] when*
-    ] bind ;
+    ] with-stream ;
 
 : quit-flag ( -- ? )
     "httpd-quit" get ;
@@ -89,10 +89,14 @@ USE: url-encoding
     [
         quit-flag not
     ] [
-        dup accept dup httpd-client fclose
+        dup accept httpd-client
     ] while ;
 
 : httpd ( port -- )
     [
-        <server> httpd-loop fclose clear-quit-flag
+        <server> [
+            httpd-loop
+        ] [
+            swap fclose clear-quit-flag rethrow
+        ] catch
     ] with-logging ;

library/httpd/test-responder.factor

@@ -27,7 +27,7 @@
 
 IN: test-responder
 USE: stdio
-USE: unparser
+USE: prettyprint
 
 USE: httpd
 USE: httpd-responder

library/inspect-vocabularies.factor

@@ -31,6 +31,7 @@ USE: inspector
 USE: lists
 USE: kernel
 USE: namespaces
+USE: prettyprint
 USE: stack
 USE: stdio
 USE: strings

library/inspector.factor

@@ -74,11 +74,11 @@ USE: vocabularies
         [ string? ]
         [ print ]
         
-        [ namespace? ]
+        [ has-namespace? ]
         [ dup describe-banner describe-namespace ]
         
         [ drop t ]
-        [ prettyprint terpri ]
+        [ prettyprint ]
     ] cond ;
 
 : describe-object-path ( string -- )

library/platform/jvm/debugger.factor

@@ -29,9 +29,9 @@ IN: debugger
 USE: combinators
 USE: kernel
 USE: namespaces
+USE: prettyprint
 USE: stack
 USE: stdio
-USE: unparser
 
 : exception? ( exception -- boolean )
     "java.lang.Throwable" is ;

library/platform/jvm/unparser.factor

@@ -27,8 +27,6 @@
 
 IN: unparser
 USE: kernel
-USE: lists
-USE: stdio
 USE: strings
 
 : fixnum>str >str ; inline
@@ -37,13 +35,6 @@ USE: strings
     [ "java.lang.Object" ] "factor.FactorReader" "unparseObject"
     jinvoke-static ;
 
-: . ( expr -- )
-    unparse print ;
-
-: [.] ( list -- )
-    #! Unparse each element on its own line.
-    [ . ] each ;
-
 : >base ( num radix -- string )
     #! Convert a number to a string in a certain base.
     [ "int" "int" ]

library/platform/native/boot.factor

@@ -100,7 +100,7 @@ primitives,
     max 2list length reverse nth list? 2rlist
     all? clone-list clone-list-iter subset subset-iter
     subset-add car= cdr= cons= cons-hashcode
-    tree-contains? =-or-contains?
+    tree-contains? =-or-contains? last* last
 ] [ worddef worddef, ] each
 
 version,

library/platform/native/errors.factor

@@ -53,15 +53,23 @@ USE: vectors
 
 : error# ( n -- str )
     [
-        "Handle expired"
+        "Handle expired: "
-        "Undefined word"
+        "Undefined word: "
-        "Type check"
+        "Type check: "
-        "Array range check"
+        "Array range check: "
         "Underflow"
+        "Bad primitive: "
     ] ?nth ;
 
+: ?kernel-error ( cons -- error# param )
+    dup cons? [
+        uncons dup cons? [ car ] when
+    ] [
+        f
+    ] ifte ;
+
 : kernel-error>str ( error -- )
-    <% car error# % ": " % unparse % %> ;
+    <% ?kernel-error swap error# % [ unparse % ] when* %> ;
 
 : error>str ( error -- str )
     dup kernel-error? [

library/platform/native/image.factor

@@ -35,6 +35,7 @@ USE: kernel
 USE: lists
 USE: logic
 USE: namespaces
+USE: prettyprint
 USE: stack
 USE: stdio
 USE: streams

library/platform/native/parse-stream.factor

@@ -39,21 +39,31 @@ USE: streams
     "parse-stream" get freadln
     "line-number" succ@ ;
 
-: (parse-stream) ( -- )
+: (read-lines) ( quot -- )
-    next-line [ (parse) (parse-stream) ] when* ;
+    next-line dup [
+        swap dup >r call r> (read-lines)
+    ] [
+        2drop
+    ] ifte ;
 
-: <parse-stream ( name stream -- )
+: read-lines ( stream quot -- )
-    "parse-stream" set
+    #! Apply a quotation to each line as its read. Close the
+    #! stream.
+    swap [
+        "parse-stream" set 0 "line-number" set (read-lines)
+    ] [
+        "parse-stream" get fclose rethrow
+    ] catch ;
+
+: init-parser ( name -- seed )
     "parse-name" set
-    0 "line-number" set ;
+    "user" "in" set
+    [ "builtins" "user" ] "use" set
+    f ;
 
-: parse-stream ( name stream -- )
+: parse-stream ( name stream -- code )
     <namespace> [
-        [
+        >r init-parser r> [ (parse) ] read-lines nreverse
-            <parse-stream f (parse-stream) nreverse
-        ] [
-            "parse-stream" get fclose rethrow
-        ] catch
     ] bind ;
 
 : parse-file ( file -- code )

library/platform/native/parser.factor

@@ -41,13 +41,29 @@ USE: unparser
 
 ! Number parsing
 
-: base "base" get ;
+: letter? #\a #\z between? ;
-: set-base "base" set ;
+: LETTER? #\A #\Z between? ;
 : digit? #\0 #\9 between? ;
-: >digit #\0 + ;
+
 : not-a-number "Not a number" throw ;
-: digit> dup digit? [ #\0 - ] [ not-a-number ] ifte ;
+
-: digit ( num digit -- num ) >r base * r> + ;
+: digit> ( ch -- n )
+    [
+        [ digit? ] [ #\0 - ]
+        [ letter? ] [ #\a - 10 + ]
+        [ LETTER? ] [ #\A - 10 + ]
+        [ drop t ] [ not-a-number ]
+    ] cond ;
+
+: >digit ( n -- ch )
+    dup 10 < [ #\0 + ] [ 10 - #\a + ] ifte ;
+
+: digit ( num digit -- num )
+    "base" get swap 2dup >= [
+        >r * r> +
+    ] [
+        not-a-number
+    ] ifte ;
 
 : (str>fixnum) ( str -- num )
     0 swap [ digit> digit ] str-each ;
@@ -74,7 +90,13 @@ USE: unparser
 ! of vocabularies. If it is a parsing word, it is executed
 ! immediately. Otherwise it is appended to the parse tree.
 
-: parsing? ( word -- ? ) "parsing" swap word-property ;
+: parsing? ( word -- ? )
+    dup word? [
+        "parsing" swap word-property
+    ] [
+        drop f
+    ] ifte ;
+
 : parsing ( -- ) t "parsing" word set-word-property ;
 
 : <parsing "line" set 0 "pos" set ;
@@ -109,16 +131,22 @@ USE: unparser
 : scan ( -- str )
     (scan) 2dup = [ 2drop f ] [ "line" get substring ] ifte ;
 
+: parse-word ( str -- obj )
+    dup "use" get search dup [
+        nip
+    ] [
+        drop str>fixnum
+    ] ifte ;
+
+: parsed ( obj -- )
+    swons ;
+
 : number, ( num -- )
-    str>fixnum swons ;
+    str>fixnum parsed ;
 
 : word, ( str -- )
     [
-        dup "use" get search dup [
+        parse-word dup parsing? [ execute ] [ parsed ] ifte
-            nip dup parsing? [ execute ] [ swons ] ifte
-        ] [
-            drop number,
-        ] ifte
     ] when* ;
 
 : (parse) <parsing [ end? not ] [ scan word, ] while parsing> ;
@@ -152,13 +180,23 @@ USE: unparser
 IN: builtins
 
 ! Constants
-: t t swons ; parsing
+: t t parsed ; parsing
-: f f swons ; parsing
+: f f parsed ; parsing
 
 ! Lists
 : [ f ; parsing
-: ] nreverse swons ; parsing
+: ] nreverse parsed ; parsing
-    
+
+: expect-] scan "]" = not [ "Expected ]" throw ] when ;
+
+: one-word ( -- obj ) f scan word, car ;
+
+: | ( syntax: | cdr ] )
+    #! See the word 'parsed'.
+    "|"
+    nreverse dup last* one-word swap rplacd parsed
+    expect-] ; parsing
+
 ! Colon defs
 : :
     #! Begin a word definition. Word name follows.
@@ -189,22 +227,33 @@ IN: builtins
 
 ! String literal
 
-: scan-escape ( -- )
+: parse-escape ( -- )
     next-ch escape dup [ % ] [ drop "Bad escape" throw ] ifte ;
 
-: scan-string ( -- )
+: parse-string ( -- )
     next-ch dup #\" = [
         drop
     ] [
-        dup #\\\ = [ drop scan-escape ] [ % ] ifte scan-string
+        dup #\\\ = [ drop parse-escape ] [ % ] ifte parse-string
     ] ifte ;
 
 : "
     #! Note the ugly hack to carry the new value of 'pos' from
     #! the <% %> scope up to the original scope.
-    <% scan-string "pos" get %> swap "pos" set swons ; parsing
+    <% parse-string "pos" get %> swap "pos" set parsed ; parsing
 
 ! Comments
 : ( ")" until drop ; parsing
 : ! until-eol drop ; parsing
 : #! until-eol drop ; parsing
+    
+! Reading numbers in other bases
+
+: BASE: ( base -- )
+    #! Read a number in a specific base.
+    "base" get >r "base" set scan number, r> "base" set ;
+
+: HEX: 16 BASE: ; parsing
+: DEC: 10 BASE: ; parsing
+: OCT: 8 BASE: ; parsing
+: BIN: 2 BASE: ; parsing

library/platform/native/prettyprint.factor

@@ -27,6 +27,7 @@
 
 IN: prettyprint
 USE: combinators
+USE: parser
 USE: prettyprint
 USE: stack
 USE: stdio
@@ -34,20 +35,25 @@ USE: unparser
 USE: vocabularies
 USE: words
 
-: see ( word -- )
+: see-compound ( word -- )
-    !!! Ugh!
+    0 swap dup word-parameter
-    intern dup compound? [
+    [
-        0 swap dup word-parameter
+        [ prettyprint-: ] dip prettyprint-word
-        [
+        dup prettyprint-newline
-            [ prettyprint-: ] dip prettyprint-word
+    ] dip
-            dup prettyprint-newline
+    prettyprint-list prettyprint-;
-        ] dip
+    prettyprint-newline ;
-        prettyprint-list prettyprint-;
+
-        prettyprint-newline
+: see-primitive ( word -- )
-    ] [
+    "Primitive: " write unparse print ;
-        dup primitive? [
+
-            "Primitive: " write unparse print
+: see-undefined ( word -- )
-        ] [
+    drop "Not defined" print ;
-            drop "Not defined" print
+
-        ] ifte
+: see ( name -- )
-    ] ifte ;
+    intern
+    [
+        [ compound? ] [ see-compound ]
+        [ primitive? ] [ see-primitive ]
+        [ drop t ] [ see-undefined ]
+    ] cond ;

library/platform/native/unparser.factor

@@ -40,7 +40,11 @@ USE: words
 USE: vocabularies
 
 : fixnum% ( num -- )
-    base /mod swap dup 0 > [ fixnum% ] [ drop ] ifte >digit % ;
+    "base" get /mod swap dup 0 > [
+        fixnum%
+    ] [
+        drop
+    ] ifte >digit % ;
 
 : fixnum- ( num -- num )
     dup 0 < [ "-" % neg ] when ;
@@ -62,12 +66,5 @@ USE: vocabularies
         [ word?   ] [ unparse-word ]
         [ fixnum? ] [ fixnum>str ]
         [ string? ] [ unparse-str ]
-        [ drop t  ] [ drop "#<unknown>" ]
+        [ drop t  ] [ <% "#<" % class-of % ">" % %> ]
     ] cond ;
-
-: . ( expr -- )
-    unparse print ;
-
-: [.] ( list -- )
-    #! Unparse each element on its own line.
-    [ . ] each ;

library/prettyprint.factor

@@ -58,51 +58,64 @@ USE: words
 : prettyprint-space ( -- )
     " " write ;
 
-: prettyprint-[ ( indent -- indent )
+: newline-after? ( obj -- ? )
-    "[" write
+    comment? ;
-    tab-size + dup prettyprint-newline ;
-
-: prettyprint-] ( indent -- indent )
-    tab-size - dup prettyprint-newline
-    "]" write
-    prettyprint-space ;
 
 ! Real definition follows
 DEFER: prettyprint*
 
+: prettyprint-element ( indent obj -- indent )
+    dup >r prettyprint* r> newline-after? [
+        dup prettyprint-newline
+    ] [
+        prettyprint-space
+    ] ifte ;
+
+: <prettyprint ( indent -- indent )
+    tab-size +
+    "prettyprint-single-line" get [
+        prettyprint-space
+    ] [
+        dup prettyprint-newline
+    ] ifte ;
+
+: prettyprint> ( indent -- indent )
+    tab-size -
+    "prettyprint-single-line" get [
+        dup prettyprint-newline
+    ] unless ;
+
+: prettyprint-[ ( indent -- indent )
+    "[" write <prettyprint ;
+
+: prettyprint-] ( indent -- indent )
+    prettyprint> "]" write ;
+
 : prettyprint-list ( indent list -- indent )
     #! Pretty-print a list, without [ and ].
-    [ prettyprint* ] each ;
+    [ prettyprint-element ] each ;
 
 : prettyprint-[] ( indent list -- indent )
     swap prettyprint-[ swap prettyprint-list prettyprint-] ;
 
 : prettyprint-{ ( indent -- indent )
-    "{" write
+    "{" write <prettyprint ;
-    tab-size + dup prettyprint-newline ;
 
 : prettyprint-} ( indent -- indent )
-    tab-size - dup prettyprint-newline
+    prettyprint> "}" write ;
-    "}" write
-    prettyprint-space ;
 
 : prettyprint-vector ( indent list -- indent )
     #! Pretty-print a vector, without { and }.
-    [ prettyprint* ] vector-each ;
+    [ prettyprint-element ] vector-each ;
 
 : prettyprint-{} ( indent list -- indent )
     swap prettyprint-{ swap prettyprint-vector prettyprint-} ;
 
-: write-comment ( comment -- )
+: trim-newline ( str -- str )
-    [ "comments" ] get-style [ write-attr ] bind ;
+    dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
 
-: prettyprint-comment ( indent obj -- indent )
+: prettyprint-comment ( comment -- )
-    ends-with-newline? dup [
+    [ "comments" ] get-style [ trim-newline write-attr ] bind ;
-        write-comment terpri
-        dup prettyprint-indent
-    ] [
-        drop write-comment " " write
-    ] ifte ;
 
 : word-link ( word -- link )
     <%
@@ -121,14 +134,14 @@ DEFER: prettyprint*
     ] ifte ;
 
 : prettyprint-word ( word -- )
-    dup word-attrs [ word-name write-attr ] bind " " write ;
+    dup word-attrs [ word-name write-attr ] bind ;
 
 : prettyprint-object ( indent obj -- indent )
-    unparse write " " write ;
+    unparse write ;
 
 : prettyprint* ( indent obj -- indent )
     [
-        [ not       ] [ prettyprint-object ]
+        [ f =       ] [ prettyprint-object ]
         [ list?     ] [ prettyprint-[] ]
         [ vector?   ] [ prettyprint-{} ]
         [ comment?  ] [ prettyprint-comment ]
@@ -136,8 +149,8 @@ DEFER: prettyprint*
         [ drop t    ] [ prettyprint-object ]
     ] cond ;
 
-: prettyprint ( list -- )
+: prettyprint ( obj -- )
-    0 swap prettyprint* drop ;
+    0 swap prettyprint* drop terpri ;
 
 : prettyprint-: ( indent -- indent )
     ":" write prettyprint-space
@@ -148,10 +161,21 @@ DEFER: prettyprint*
     tab-size - ;
 
 : prettyprint-:; ( indent word list -- indent )
-    [ [ prettyprint-: ] dip prettyprint-word ] dip
+    >r
+    >r prettyprint-: r>
+    prettyprint-word prettyprint-space r>
     prettyprint-list prettyprint-; ;
 
-: .n namestack  prettyprint ;
+: . ( obj -- )
-: .s datastack  prettyprint ;
+    <namespace> [
-: .r callstack  prettyprint ;
+        "prettyprint-single-line" on prettyprint
-: .c catchstack prettyprint ;
+    ] bind ;
+
+: [.] ( list -- )
+    #! Unparse each element on its own line.
+    [ . ] each ;
+
+: .n namestack  . ;
+: .s datastack  . ;
+: .r callstack  . ;
+: .c catchstack . ;

library/stream.factor

@@ -30,6 +30,8 @@ USE: errors
 USE: kernel
 USE: namespaces
 
+! Generic functions, of sorts...
+
 : fflush ( stream -- )
     [ "fflush" get call ] bind ;
 
@@ -79,6 +81,8 @@ USE: namespaces
     ] extend ;
 
 : <extend-stream> ( stream -- stream )
+    #! Create a stream that wraps another stream. Override some
+    #! or all of the stream words.
     <stream> [
         "stream" set
         ( -- string )

library/test/test.factor

@@ -11,6 +11,7 @@ USE: kernel
 USE: lists
 USE: namespaces
 USE: parser
+USE: prettyprint
 USE: stack
 USE: stdio
 USE: strings