From 173963d438f382b8690c8908dfdf4045d02b6116 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 21 Jul 2004 23:26:41 +0000 Subject: [PATCH] work on native factor, httpd now uses catch --- TODO.FACTOR.txt | 3 - library/debugger.factor | 8 +- library/httpd/httpd.factor | 16 ++-- library/httpd/test-responder.factor | 2 +- library/inspect-vocabularies.factor | 1 + library/inspector.factor | 4 +- library/platform/jvm/debugger.factor | 2 +- library/platform/jvm/unparser.factor | 9 -- library/platform/native/.image.factor.marks | Bin 39 -> 39 bytes library/platform/native/boot.factor | 2 +- library/platform/native/errors.factor | 18 ++-- library/platform/native/image.factor | 1 + library/platform/native/parse-stream.factor | 32 ++++--- library/platform/native/parser.factor | 89 ++++++++++++++----- library/platform/native/prettyprint.factor | 40 +++++---- library/platform/native/unparser.factor | 15 ++-- library/prettyprint.factor | 92 ++++++++++++-------- library/stream.factor | 4 + library/test/test.factor | 1 + 19 files changed, 216 insertions(+), 123 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 3b0ff27616..3f5be759b7 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/debugger.factor b/library/debugger.factor index 99ab582591..7691e4b5d2 100644 --- a/library/debugger.factor +++ b/library/debugger.factor @@ -65,7 +65,7 @@ USE: unparser suspend ; -: :s ( -- ) "error-datastack" get prettyprint ; -: :r ( -- ) "error-callstack" get prettyprint ; -: :n ( -- ) "error-namestack" get prettyprint ; -: :c ( -- ) "error-catchstack" get prettyprint ; +: :s ( -- ) "error-datastack" get . ; +: :r ( -- ) "error-callstack" get . ; +: :n ( -- ) "error-namestack" get . ; +: :c ( -- ) "error-catchstack" get . ; diff --git a/library/httpd/httpd.factor b/library/httpd/httpd.factor index e7ecb7f5f8..4c06743cb1 100644 --- a/library/httpd/httpd.factor +++ b/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 -- ) - [ - dup "client" set "stdio" set - log-client + [ + "stdio" get "client" set 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 -- ) [ - httpd-loop fclose clear-quit-flag + [ + httpd-loop + ] [ + swap fclose clear-quit-flag rethrow + ] catch ] with-logging ; diff --git a/library/httpd/test-responder.factor b/library/httpd/test-responder.factor index 6fe5caa957..38920023a9 100644 --- a/library/httpd/test-responder.factor +++ b/library/httpd/test-responder.factor @@ -27,7 +27,7 @@ IN: test-responder USE: stdio -USE: unparser +USE: prettyprint USE: httpd USE: httpd-responder diff --git a/library/inspect-vocabularies.factor b/library/inspect-vocabularies.factor index 1bd1d32c29..7c33d922dd 100644 --- a/library/inspect-vocabularies.factor +++ b/library/inspect-vocabularies.factor @@ -31,6 +31,7 @@ USE: inspector USE: lists USE: kernel USE: namespaces +USE: prettyprint USE: stack USE: stdio USE: strings diff --git a/library/inspector.factor b/library/inspector.factor index b0c1ee7ec2..a11eaeb0af 100644 --- a/library/inspector.factor +++ b/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 -- ) diff --git a/library/platform/jvm/debugger.factor b/library/platform/jvm/debugger.factor index ec4f9cfaaa..2ef8ec5fff 100644 --- a/library/platform/jvm/debugger.factor +++ b/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 ; diff --git a/library/platform/jvm/unparser.factor b/library/platform/jvm/unparser.factor index 39136d6139..9df7be59f4 100644 --- a/library/platform/jvm/unparser.factor +++ b/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" ] diff --git a/library/platform/native/.image.factor.marks b/library/platform/native/.image.factor.marks index fe7e27848969092c0f0c901de4e50b1fbe2cdd48..fac84b4fde01a16752076cd91dda49d7568d8503 100644 GIT binary patch literal 39 hcmY#Pv^KIdHvkh{iVW7K2F3m*hw=f42TmY1c2QdHu literal 39 hcmY#Pv^KIdH3k!0iVW7K28PC90>m*hH#YziTmY1q2PFUi diff --git a/library/platform/native/boot.factor b/library/platform/native/boot.factor index 8ad4a3ccdc..75619d5ebd 100644 --- a/library/platform/native/boot.factor +++ b/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, diff --git a/library/platform/native/errors.factor b/library/platform/native/errors.factor index 7dae9eadb0..c2486caa94 100644 --- a/library/platform/native/errors.factor +++ b/library/platform/native/errors.factor @@ -53,15 +53,23 @@ USE: vectors : error# ( n -- str ) [ - "Handle expired" - "Undefined word" - "Type check" - "Array range check" + "Handle expired: " + "Undefined word: " + "Type 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? [ diff --git a/library/platform/native/image.factor b/library/platform/native/image.factor index 67bcc58a06..99a6640ce2 100644 --- a/library/platform/native/image.factor +++ b/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 diff --git a/library/platform/native/parse-stream.factor b/library/platform/native/parse-stream.factor index ff82494179..c8d19a3247 100644 --- a/library/platform/native/parse-stream.factor +++ b/library/platform/native/parse-stream.factor @@ -39,21 +39,31 @@ USE: streams "parse-stream" get freadln "line-number" succ@ ; -: (parse-stream) ( -- ) - next-line [ (parse) (parse-stream) ] when* ; +: (read-lines) ( quot -- ) + next-line dup [ + swap dup >r call r> (read-lines) + ] [ + 2drop + ] ifte ; -: [ - [ - r init-parser r> [ (parse) ] read-lines nreverse ] bind ; : parse-file ( file -- code ) diff --git a/library/platform/native/parser.factor b/library/platform/native/parser.factor index 94d73d165c..2a7a6e34a9 100644 --- a/library/platform/native/parser.factor +++ b/library/platform/native/parser.factor @@ -41,13 +41,29 @@ USE: unparser ! Number parsing -: base "base" get ; -: set-base "base" set ; +: letter? #\a #\z between? ; +: 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 ; : fixnum + ] ifte ; + +: parsed ( obj -- ) + swons ; + : number, ( num -- ) - str>fixnum swons ; + str>fixnum parsed ; : word, ( str -- ) [ - dup "use" get search dup [ - nip dup parsing? [ execute ] [ swons ] ifte - ] [ - drop number, - ] ifte + parse-word dup parsing? [ execute ] [ parsed ] ifte ] when* ; : (parse) ; @@ -152,13 +180,23 @@ USE: unparser IN: builtins ! Constants -: t t swons ; parsing -: f f swons ; parsing +: t t parsed ; 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 diff --git a/library/platform/native/prettyprint.factor b/library/platform/native/prettyprint.factor index ff586c5f60..55032fd286 100644 --- a/library/platform/native/prettyprint.factor +++ b/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 -- ) - !!! Ugh! - intern dup compound? [ - 0 swap dup word-parameter - [ - [ prettyprint-: ] dip prettyprint-word - dup prettyprint-newline - ] dip - prettyprint-list prettyprint-; - prettyprint-newline - ] [ - dup primitive? [ - "Primitive: " write unparse print - ] [ - drop "Not defined" print - ] ifte - ] ifte ; +: see-compound ( word -- ) + 0 swap dup word-parameter + [ + [ prettyprint-: ] dip prettyprint-word + dup prettyprint-newline + ] dip + prettyprint-list prettyprint-; + prettyprint-newline ; + +: see-primitive ( word -- ) + "Primitive: " write unparse print ; + +: see-undefined ( word -- ) + drop "Not defined" print ; + +: see ( name -- ) + intern + [ + [ compound? ] [ see-compound ] + [ primitive? ] [ see-primitive ] + [ drop t ] [ see-undefined ] + ] cond ; diff --git a/library/platform/native/unparser.factor b/library/platform/native/unparser.factor index ca9879fc21..d3ea7ca55d 100644 --- a/library/platform/native/unparser.factor +++ b/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 "#" ] + [ drop t ] [ <% "#<" % class-of % ">" % %> ] ] cond ; - -: . ( expr -- ) - unparse print ; - -: [.] ( list -- ) - #! Unparse each element on its own line. - [ . ] each ; diff --git a/library/prettyprint.factor b/library/prettyprint.factor index 2df9c22abf..749a4bda1b 100644 --- a/library/prettyprint.factor +++ b/library/prettyprint.factor @@ -58,51 +58,64 @@ USE: words : prettyprint-space ( -- ) " " write ; -: prettyprint-[ ( indent -- indent ) - "[" write - tab-size + dup prettyprint-newline ; - -: prettyprint-] ( indent -- indent ) - tab-size - dup prettyprint-newline - "]" write - prettyprint-space ; +: newline-after? ( obj -- ? ) + comment? ; ! Real definition follows DEFER: prettyprint* +: prettyprint-element ( indent obj -- indent ) + dup >r prettyprint* r> newline-after? [ + dup prettyprint-newline + ] [ + prettyprint-space + ] ifte ; + +: ( indent -- indent ) + tab-size - + "prettyprint-single-line" get [ + dup prettyprint-newline + ] unless ; + +: prettyprint-[ ( indent -- indent ) + "[" write "]" 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 - tab-size + dup prettyprint-newline ; + "{" write "}" write ; : 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 -- ) - [ "comments" ] get-style [ write-attr ] bind ; +: trim-newline ( str -- str ) + dup ends-with-newline? dup [ nip ] [ drop ] ifte ; -: prettyprint-comment ( indent obj -- indent ) - ends-with-newline? dup [ - write-comment terpri - dup prettyprint-indent - ] [ - drop write-comment " " write - ] ifte ; +: prettyprint-comment ( comment -- ) + [ "comments" ] get-style [ trim-newline write-attr ] bind ; : 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 -- ) - 0 swap prettyprint* drop ; +: prettyprint ( obj -- ) + 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 ; -: .s datastack prettyprint ; -: .r callstack prettyprint ; -: .c catchstack prettyprint ; +: . ( obj -- ) + [ + "prettyprint-single-line" on prettyprint + ] bind ; + +: [.] ( list -- ) + #! Unparse each element on its own line. + [ . ] each ; + +: .n namestack . ; +: .s datastack . ; +: .r callstack . ; +: .c catchstack . ; diff --git a/library/stream.factor b/library/stream.factor index f857332cb5..55456934bc 100644 --- a/library/stream.factor +++ b/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 ; : ( stream -- stream ) + #! Create a stream that wraps another stream. Override some + #! or all of the stream words. [ "stream" set ( -- string ) diff --git a/library/test/test.factor b/library/test/test.factor index 08b7ae181f..fc570bd5f6 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -11,6 +11,7 @@ USE: kernel USE: lists USE: namespaces USE: parser +USE: prettyprint USE: stack USE: stdio USE: strings