</li>
+<li>Prettyprinter:
+
+<ul>
+<li>The prettyprinter has been merged with the unparser. The <code>unparse ( object -- string )</code> word has been moved to the <code>prettyprint</code> vocabulary, and can now produce a parsable string for any class supported by the prettyprinter.</li>
+<li>New <code>unparse-short ( object -- string )</code> returns a string no longer than a single line.</li>
+<li>The prettyprinter now supports many more configuration variables. See the handbook for details.</li>
+</ul>
+
+</li>
+
<li>Everything else:
<ul>
! See http://factor.sf.net/license.txt for BSD license.
IN: alien
USING: assembler compiler compiler-backend compiler-frontend
-errors generic hashtables inference kernel lists math namespaces
-sequences io strings unparser words ;
+errors generic hashtables inference io kernel lists math
+namespaces prettyprint sequences strings words ;
! ! ! WARNING ! ! !
! Reloading this file into a running Factor instance on Win32
: incr-param ( reg-class -- )
#! OS X is so ugly.
- dup class [ 1 + ] change dup float-regs? [
+ dup class inc dup float-regs? [
os "macosx" = [
int-regs [ swap float-regs-size 4 / + ] change
] [
#! END-ENUM
#!
#! This is the same as : x 0 ; : y 1 ; : z 2 ;.
- scan str>number ; parsing
+ scan string>number ; parsing
: ENUM:
dup CREATE swap unit define-compound 1 + ; parsing
"/library/alien/aliens.factor"
- "/library/syntax/unparser.factor"
"/library/syntax/prettyprint.factor"
"/library/tools/gensym.factor"
! Copyright (C) 2004, 2005 Slava Pestov.\r
! See http://factor.sf.net/license.txt for BSD license.\r
USING: alien assembler command-line compiler errors generic\r
-hashtables io kernel lists memory namespaces parser sequences\r
-unparser words ;\r
+hashtables io kernel lists memory namespaces parser sequences words ;\r
\r
: pull-in ( ? list -- )\r
swap [\r
! See http://factor.sf.net/license.txt for BSD license.
USING: alien assembler command-line compiler compiler-backend
compiler-frontend inference io-internals kernel lists math
-namespaces parser sequences io unparser words ;
+namespaces parser sequences io words ;
"Compiling base..." print
\ car compile
\ * compile
\ = compile
- \ unparse compile
+ \ string>number compile
+ \ number>string compile
\ scan compile
\ (generate) compile
] when
IN: kernel
USING: alien assembler command-line compiler console errors
generic inference kernel-internals listener lists math memory
-namespaces parser presentation prettyprint random io
-unparser words ;
+namespaces parser presentation prettyprint random io words ;
"Bootstrap stage 4..." print
terpri
0 [ compiled? [ 1 + ] when ] each-word
-unparse write " words compiled" print
+number>string write " words compiled" print
0 [ drop 1 + ] each-word
-unparse write " words total" print
+number>string write " words total" print
-"Total bootstrap GC time: " write gc-time unparse write " ms" print
+"Total bootstrap GC time: " write gc-time
+number>string write " ms" print
"Bootstrapping is complete." print
"Now, you can run ./f factor.image" print
{ ">float" "math" }
{ "(fraction>)" "math-internals" }
{ "str>float" "parser" }
- { "(unparse-float)" "unparser" }
+ { "(unparse-float)" "parser" }
{ "float>bits" "math" }
{ "double>bits" "math" }
{ "bits>float" "math" }
: set ( value variable -- ) namespace set-hash ;
-: on ( var -- ) t swap set ;
-
-: off ( var -- ) f swap set ;
-
: nest ( variable -- hash )
#! If the variable is set in the current namespace, return
#! its value, otherwise set its value to a new namespace.
#! quotation.
>r dup get r> rot slip set ; inline
+: on ( var -- ) t swap set ; inline
+
+: off ( var -- ) f swap set ; inline
+
+: inc ( var -- ) [ 1 + ] change ; inline
+
+: dec ( var -- ) [ 1 - ] change ; inline
+
: bind ( namespace quot -- )
#! Execute a quotation with a namespace on the namestack.
swap >n call n> drop ; inline
: flip ( seq -- seq )
#! An example illustrates this word best:
- #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 2 } { 3 4 } { 5 6 } }
+ #! { { 1 2 3 } { 4 5 6 } } ==> { { 1 4 } { 2 5 } { 3 6 } }
dup empty? [
dup first length [ swap [ nth ] map-with ] map-with
] unless ; flushable
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: cont-responder
USING: http httpd math random namespaces io
- lists strings kernel html unparser hashtables
+ lists strings kernel html hashtables
parser generic sequences ;
#! Used inside the session state of responders to indicate whether the
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
- [ 32 [ 0 9 random-int unparse % ] times ] make-string str>number 36 >base ;
+ [ 32 [ 0 9 random-int CHAR: 0 + , ] times ] make-string
+ string>number 36 >base ;
#! Name of variable holding the table of continuations.
SYMBOL: table
! See http://factor.sf.net/license.txt for BSD license.
IN: file-responder
USING: html httpd kernel lists namespaces parser sequences
-io strings unparser ;
+io strings ;
: serving-path ( filename -- filename )
[ "" ] unless* "doc-root" get swap append ;
: file-response ( mime-type length -- )
[
- unparse "Content-Length" swons ,
+ number>string "Content-Length" swons ,
"Content-Type" swons ,
] make-list "200 OK" response terpri ;
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: html
-USING: #<unknown> generic http io kernel lists namespaces
-presentation sequences strings styles unparser words ;
+USING: generic http io kernel lists namespaces parser
+presentation sequences strings styles words ;
: html-entities ( -- alist )
[
[ "text-decoration: underline; " % ] when ;
: size-css, ( size -- )
- "font-size: " % unparse % "; " % ;
+ "font-size: " % number>string % "; " % ;
: font-css, ( font -- )
"font-family: " % % "; " % ;
! See http://factor.sf.net/license.txt for BSD license.
IN: http-client
USING: errors http kernel lists namespaces parser sequences
-io strings unparser ;
+io strings ;
: parse-host ( url -- host port )
#! Extract the host name and port number from an HTTP URL.
- ":" split1 [ str>number ] [ 80 ] ifte* ;
+ ":" split1 [ string>number ] [ 80 ] ifte* ;
: parse-url ( url -- host resource )
"http://" ?head [
: parse-response ( line -- code )
"HTTP/" ?head [ " " split1 nip ] when
- " " split1 drop str>number ;
+ " " split1 drop string>number ;
: read-response ( -- code header )
#! After sending a GET oR POST we read a response line and
#! header.
flush readln parse-response read-header ;
+: crlf "\r\n" write ;
+
: http-request ( host resource method -- )
write " " write write " HTTP/1.0" write crlf
"Host: " write write crlf ;
#! Note: It is up to the caller to url encode the content if
#! it is required according to the content-type.
"POST" http-request [
- "Content-Length: " write length unparse write crlf
- "Content-Type: " write write crlf
+ "Content-Length: " write length number>string write crlf
+ "Content-Type: " write url-encode write crlf
crlf
] keep write ;
! Copyright (C) 2003, 2005 Slava Pestov
IN: http
USING: errors kernel lists math namespaces parser sequences
-io strings unparser ;
+io strings ;
: header-line ( alist line -- alist )
": " split1 dup [ cons swons ] [ 2drop ] ifte ;
: read-post-request ( header -- alist )
"Content-Length" swap assoc dup
- [ str>number read query>alist ] when ;
+ [ string>number read query>alist ] when ;
: log-user-agent ( alist -- )
"User-Agent" swap assoc* [
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: errors generic hashtables interpreter kernel lists math
-namespaces prettyprint sequences strings unparser vectors words ;
+namespaces parser prettyprint sequences strings vectors words ;
: unify-lengths ( seq -- seq )
#! Pad all vectors to the same length. If one vector is
[ unify-stacks >r unify-stacks r> ]
[
{ "Unbalanced branches:" } -rot [
- swap length unparse " " rot length unparse append3
+ swap length number>string
+ " " rot length number>string append3
] 2map append "\n" join inference-error
] ifte ;
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: errors generic interpreter io kernel lists math
-namespaces prettyprint sequences strings unparser vectors words ;
+namespaces parser prettyprint sequences strings vectors words ;
! This variable takes a boolean value.
SYMBOL: inferring-base-case
: check-return ( -- )
#! Raise an error if word leaves values on return stack.
meta-r get empty? [
- "Word leaves " meta-r get length unparse
+ "Word leaves " meta-r get length number>string
" element(s) on return stack. Check >r/r> usage." append3
inference-error
] unless ;
IN: inference
USING: alien assembler errors generic hashtables interpreter io
io-internals kernel kernel-internals lists math math-internals
-memory parser sequences strings unparser vectors words ;
+memory parser sequences strings vectors words prettyprint ;
! Primitive combinators
\ call [
! See http://factor.sf.net/license.txt for BSD license.
IN: io
USING: hashtables kernel lists namespaces presentation sequences
-strings styles unparser ;
+strings styles ;
! Hyperlinked directory listings.
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io
-USING: kernel namespaces io sequences strings unparser ;
+USING: io kernel namespaces parser sequences strings ;
! A simple logging framework.
SYMBOL: log-stream
"Accepted connection from " %
dup client-stream-host %
CHAR: : ,
- client-stream-port unparse %
+ client-stream-port number>string %
] make-string log ;
: with-log-file ( file quot -- )
: terpri ( -- ) stdio get stream-terpri ;\r
: close ( -- ) stdio get stream-close ;\r
\r
-: crlf ( -- ) "\r\n" write ;\r
-\r
: write-icon ( resource -- )\r
#! Write an icon. Eg, /library/icons/File.png\r
icon swons unit "" swap format ;\r
\r
+: write-object ( string object -- )\r
+ presented swons unit format ;\r
+\r
: with-stream ( stream quot -- )\r
#! Close the stream no matter what happens.\r
[ swap stdio set [ close rethrow ] catch ] with-scope ;\r
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: parser
-USING: errors generic kernel math sequences strings ;
+USING: errors generic kernel math namespaces sequences strings ;
! Number parsing
#! conversion fails.
swap "-" ?head [ (base>) neg ] [ (base>) ] ifte ;
-GENERIC: str>number ( str -- num )
+GENERIC: string>number ( str -- num )
-M: string str>number 10 base> ;
+M: string string>number 10 base> ;
PREDICATE: string potential-ratio CHAR: / swap member? ;
-M: potential-ratio str>number ( str -- num )
+M: potential-ratio string>number ( str -- num )
"/" split1 >r 10 base> r> 10 base> / ;
PREDICATE: string potential-float CHAR: . swap member? ;
-M: potential-float str>number ( str -- num )
+M: potential-float string>number ( str -- num )
str>float ;
: bin> 2 base> ;
: oct> 8 base> ;
-: dec> 10 base> ;
: hex> 16 base> ;
+
+GENERIC: number>string ( str -- num )
+
+: >digit ( n -- ch )
+ dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
+
+: integer, ( num radix -- )
+ dup >r /mod >digit , dup 0 > [
+ r> integer,
+ ] [
+ r> 2drop
+ ] ifte ;
+
+: >base ( num radix -- string )
+ #! Convert a number to a string in a certain base.
+ [
+ over 0 < [
+ swap neg swap integer, CHAR: - ,
+ ] [
+ integer,
+ ] ifte
+ ] make-rstring ;
+
+: >bin ( num -- string ) 2 >base ;
+: >oct ( num -- string ) 8 >base ;
+: >hex ( num -- string ) 16 >base ;
+
+M: integer number>string ( obj -- str ) 10 >base ;
+
+M: ratio number>string ( num -- str )
+ [
+ dup
+ numerator number>string %
+ CHAR: / ,
+ denominator number>string %
+ ] make-string ;
+
+: fix-float ( str -- str )
+ #! This is terrible. Will go away when we do our own float
+ #! output.
+ CHAR: . over member? [ ".0" append ] unless ;
+
+M: float number>string ( float -- str )
+ (unparse-float) fix-float ;
! Bootstrapping trick; see doc/bootstrap.txt.
IN: !syntax
USING: alien errors generic hashtables kernel lists math
-namespaces parser sequences strings syntax unparse vectors
+namespaces parser sequences strings syntax vectors
words ;
: parsing ( -- )
! See http://factor.sf.net/license.txt for BSD license.
IN: parser
USING: errors kernel lists math namespaces sequences io
-strings unparser words ;
+strings words ;
! The parser uses a number of variables:
! line - the line being parsed
: scan-word ( -- obj )
scan dup [
dup ";" = not string-mode get and [
- dup "use" get search [ ] [ str>number ] ?ifte
+ dup "use" get search [ ] [ string>number ] ?ifte
] unless
] when ;
! See http://factor.sf.net/license.txt for BSD license.
IN: prettyprint
USING: alien generic hashtables io kernel lists math namespaces
-parser sequences strings styles unparser vectors words ;
+parser sequences strings styles vectors words ;
! TODO:
-! - newline styles: forced, long output style, normal
-! - long output flag, off with .
-! - margin & indent calculation fix
! - out of memory when printing global namespace
! - formatting HTML code
-! - limit strings
-! - merge unparse into this
! State
SYMBOL: column
SYMBOL: end-printing
! Configuration
+SYMBOL: tab-size
SYMBOL: margin
SYMBOL: nesting-limit
SYMBOL: length-limit
SYMBOL: line-limit
+SYMBOL: string-limit
global [
+ 4 tab-size set
64 margin set
recursion-check off
0 column set
last-newline? off
0 last-newline set
0 line-count set
+ string-limit off
] bind
-TUPLE: pprinter blocks block ;
+TUPLE: pprinter stack ;
GENERIC: pprint-section*
-TUPLE: section start end ;
+TUPLE: section start end nl-after? indent ;
C: section ( length -- section )
>r column [ dup rot + dup ] change r>
[ set-section-end ] keep
- [ set-section-start ] keep ;
+ [ set-section-start ] keep
+ 0 over set-section-indent ;
: section-fits? ( section -- ? )
- section-end last-newline get - margin get <= ;
+ section-end last-newline get - indent get + margin get <= ;
: line-limit? ( -- ? )
line-limit get dup [ line-count get <= ] when ;
-: fresh-line ( section -- )
- section-start last-newline set
- line-count [ 1 + ] change
+: do-indent indent get CHAR: \s fill write ;
+
+: fresh-line ( n -- )
+ last-newline set
+ line-count inc
line-limit? [ " ..." write end-printing get call ] when
- terpri indent get CHAR: \s fill write ;
+ terpri do-indent ;
TUPLE: text string style ;
C: block ( -- block )
0 <section> over set-delegate
- { } clone over set-block-sections ;
+ { } clone over set-block-sections
+ t over set-section-nl-after?
+ tab-size get over set-section-indent ;
+
+: pprinter-block pprinter-stack peek ;
+
+: block-empty? ( section -- ? )
+ dup block? [ block-sections empty? ] [ drop f ] ifte ;
: add-section ( section stream -- )
- pprinter-block block-sections push ;
+ over block-empty? [
+ 2drop
+ ] [
+ pprinter-block block-sections push
+ ] ifte ;
: text ( string style -- )
<text> pprinter get add-section ;
: bl ( -- ) " " f text ;
+: <indent ( section -- ) section-indent indent [ + ] change ;
+
+: indent> ( section -- ) section-indent indent [ swap - ] change ;
+
+: inset-section ( section -- )
+ dup <indent
+ dup section-start fresh-line dup pprint-section*
+ dup indent>
+ dup section-nl-after?
+ [ section-end fresh-line ] [ drop ] ifte ;
+
+: advance ( section -- )
+ section-start last-newline get = [
+ last-newline inc
+ ] [
+ " " write
+ ] ifte ;
+
: pprint-section ( section -- )
last-newline? get [
- dup section-fits? [
- " " write
+ last-newline? off dup section-fits? [
+ dup advance pprint-section*
] [
- dup fresh-line
- ] ifte last-newline? off
- ] when pprint-section* ;
+ inset-section
+ ] ifte
+ ] [
+ pprint-section*
+ ] ifte ;
TUPLE: newline forced? ;
M: newline pprint-section*
dup newline-forced?
- [ fresh-line ] [ drop last-newline? on ] ifte ;
-
-: section-length ( section -- n )
- dup section-end swap section-start - ;
-
-: block-indent ( block -- indent )
- block-sections first
- dup block? [ drop 0 ] [ section-length 1 + ] ifte ;
+ [ section-start fresh-line ] [ drop last-newline? on ] ifte ;
M: block pprint-section* ( block -- )
- indent get dup >r
- over block-indent + indent set
- block-sections [ pprint-section ] each
- r> indent set ;
-
-: <block ( -- )
- pprinter get dup pprinter-block over pprinter-blocks push
- <block> swap set-pprinter-block ;
+ block-sections [ pprint-section ] each ;
-: newline ( forced -- )
- <newline> pprinter get add-section ;
+: <block ( -- ) <block> pprinter get pprinter-stack push ;
-: end-block ( block -- )
- column get swap set-section-end ;
+: newline ( forced -- ) <newline> pprinter get add-section ;
-: pop-block ( pprinter -- )
- dup pprinter-blocks pop swap set-pprinter-block ;
+: end-block ( block -- ) column get swap set-section-end ;
-: block-empty? block-sections empty? ;
+: pop-block ( pprinter -- ) pprinter-stack pop drop ;
: block> ( -- )
- pprinter get dup pprinter-block dup block-empty? [
- drop pop-block
- ] [
- dup end-block swap dup pop-block add-section
- ] ifte ;
+ pprinter get dup pprinter-block
+ dup end-block swap dup pop-block add-section ;
+
+: block; ( -- )
+ pprinter get pprinter-block f swap set-section-nl-after?
+ block> ;
C: pprinter ( -- stream )
- { } clone over set-pprinter-blocks
- <block> over set-pprinter-block ;
+ <block> 1vector over set-pprinter-stack ;
: do-pprint ( pprinter -- )
[
[[ "io-internals" [ [[ foreground [ 192 0 0 ] ]] ] ]]
}} hash ;
-: object-style ( obj -- style )
- dup word? [ dup word-vocabulary vocab-style ] [ { } ] ifte
- swap presented swons add ;
+: word-style ( word -- style )
+ dup word-vocabulary vocab-style swap presented swons add ;
-: pprint-object ( obj -- )
- dup unparse swap object-style text ;
+: pprint-word ( obj -- ) dup word-name swap word-style text ;
M: object pprint* ( obj -- )
- pprint-object ;
+ "( unprintable object: " swap class word-name " )" append3
+ f text ;
+
+M: real pprint* ( obj -- )
+ number>string f text ;
+
+M: complex pprint* ( num -- )
+ \ #{ pprint-word bl
+ dup real pprint* bl imaginary pprint* bl
+ \ }# pprint-word ;
+
+: ch>ascii-escape ( ch -- esc )
+ [
+ [[ CHAR: \e "\\e" ]]
+ [[ CHAR: \n "\\n" ]]
+ [[ CHAR: \r "\\r" ]]
+ [[ CHAR: \t "\\t" ]]
+ [[ CHAR: \0 "\\0" ]]
+ [[ CHAR: \\ "\\\\" ]]
+ [[ CHAR: \" "\\\"" ]]
+ ] assoc ;
+
+: ch>unicode-escape ( ch -- esc )
+ >hex 4 CHAR: 0 pad-left "\\u" swap append ;
+
+: unparse-ch ( ch -- ch/str )
+ dup quotable? [
+ ,
+ ] [
+ dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?ifte %
+ ] ifte ;
+
+: do-string-limit ( string -- string )
+ string-limit get [
+ dup length margin get > [
+ margin get 3 - swap head "..." append
+ ] when
+ ] when ;
+
+: pprint-string ( string prefix -- )
+ [ % [ unparse-ch ] each CHAR: " , ] make-string
+ do-string-limit f text ;
+
+M: string pprint* ( str -- str ) "\"" pprint-string ;
+
+M: sbuf pprint* ( str -- str ) "SBUF\" " pprint-string ;
M: word pprint* ( word -- )
- dup parsing? [ \ POSTPONE: pprint-object bl ] when
- pprint-object ;
+ dup parsing? [ \ POSTPONE: pprint-word bl ] when pprint-word ;
+
+M: t pprint* drop "t" f text ;
+
+M: f pprint* drop "f" f text ;
+
+M: dll pprint* ( obj -- str ) dll-path "DLL\" " pprint-string ;
: nesting-limit? ( -- ? )
nesting-limit get dup
- [ pprinter get pprinter-blocks length < ] when ;
+ [ pprinter get pprinter-stack length < ] when ;
: check-recursion ( obj quot -- indent )
#! We detect circular structure.
r> [ "... " f text ] when ;
: pprint-sequence ( seq start end -- )
- <block swap pprint-object f newline
- swap pprint-elements pprint-object block> ;
+ swap pprint-word f newline <block
+ swap pprint-elements block> pprint-word ;
M: cons pprint* ( list -- )
[
[ <mirror> \ << \ >> pprint-sequence ] check-recursion ;
M: alien pprint* ( alien -- )
- \ ALIEN: pprint-object bl alien-address pprint-object ;
+ \ ALIEN: pprint-word bl alien-address number>string f text ;
M: wrapper pprint* ( wrapper -- )
dup wrapped word? [
- \ \ pprint-object bl wrapped pprint-object
+ \ \ pprint-word bl wrapped pprint-word
] [
wrapped 1vector \ W[ \ ]W pprint-sequence
] ifte ;
<pprinter> pprinter set call pprinter get do-pprint
] with-scope ; inline
-: pprint ( object -- )
- [ pprint* ] with-pprint ;
+: pprint ( object -- ) [ pprint* ] with-pprint ;
-: pprint>string ( object -- string )
- [ pprint ] string-out ;
+: unparse ( object -- str ) [ pprint ] string-out ;
: . ( obj -- ) pprint terpri ;
1 line-limit set
5 length-limit set
2 nesting-limit set
+ string-limit on
pprint
] with-scope ;
-: pprint>short-string ( object -- string )
- [ pprint-short ] string-out ;
+: unparse-short ( object -- str ) [ pprint-short ] string-out ;
: [.] ( sequence -- )
#! Unparse each element on its own line.
- [ [ pprint>short-string print ] each ] with-scope ;
+ [ dup unparse-short swap write-object terpri ] each ;
: stack. reverse-slice [.] ;
styles words ;
: declaration. ( word prop -- )
- tuck word-name word-prop
- [ bl pprint-object ] [ drop ] ifte ;
+ tuck word-name word-prop [ bl pprint-word ] [ drop ] ifte ;
: declarations. ( word -- )
[
: comment. ( comment -- )
[ [[ font-style italic ]] ] text ;
-: stack-picture ( seq -- string )
- [ [ word-name % " " % ] each ] make-string ;
+: stack-picture% ( seq -- string )
+ [ word-name % " " % ] each ;
: effect>string ( effect -- string )
- 2unseq stack-picture >r stack-picture "-- " r> append3 ;
+ [
+ " " %
+ dup first stack-picture%
+ "-- " %
+ second stack-picture%
+ ] make-string ;
: stack-effect ( word -- string )
dup "stack-effect" word-prop [ ] [
] ?ifte ;
: stack-effect. ( string -- )
- [ bl "( " swap ")" append3 comment. ] when* ;
+ [ bl "(" swap ")" append3 comment. ] when* ;
: in. ( word -- )
- <block \ IN: pprint-object bl word-vocabulary f text block>
+ <block \ IN: pprint-word bl word-vocabulary f text block;
t newline ;
: definer. ( word -- )
- dup definer pprint-object bl
- dup pprint-object
+ dup definer pprint-word bl
+ dup pprint-word
stack-effect stack-effect.
f newline ;
"\n" split [ "#!" swap append comment. t newline ] each
] when* ;
-: pprint-; \ ; pprint-object ;
+: pprint-; \ ; pprint-word ;
: see-body ( quot word -- )
dup definer. <block dup documentation. swap pprint-elements
- pprint-; declarations. block> ;
+ pprint-; declarations. block; ;
M: compound (see)
dup word-def swap see-body t newline ;
: method. ( word [[ class method ]] -- )
- <block
- \ M: pprint-object bl
- unswons pprint-object bl
- swap pprint-object t newline
- pprint-elements pprint-;
- block> t newline ;
+ \ M: pprint-word bl
+ unswons pprint-word bl
+ swap pprint-word f newline
+ <block pprint-elements pprint-;
+ block; t newline ;
M: generic (see)
<block
dup dup { "picker" "combination" } [ word-prop ] map-with
- swap see-body block> t newline
+ swap see-body block; t newline
dup methods [ method. ] each-with ;
GENERIC: class. ( word -- )
: methods. ( class -- )
#! List all methods implemented for this class.
dup metaclass [
- t newline
dup implementors [
dup in. tuck "methods" word-prop hash* method.
] each-with
] ifte ;
M: union class.
- \ UNION: pprint-object bl
- dup pprint-object bl
- "members" word-prop pprint-elements pprint-; ;
+ \ UNION: pprint-word bl
+ dup pprint-word bl
+ "members" word-prop pprint-elements pprint-; t newline ;
M: complement class.
- \ COMPLEMENT: pprint-object bl
- dup pprint-object bl
- "complement" word-prop pprint-object ;
+ \ COMPLEMENT: pprint-word bl
+ dup pprint-word bl
+ "complement" word-prop pprint-word t newline ;
M: predicate class.
- \ PREDICATE: pprint-object bl
- dup "superclass" word-prop pprint-object bl
- dup pprint-object f newline
+ \ PREDICATE: pprint-word bl
+ dup "superclass" word-prop pprint-word bl
+ dup pprint-word f newline
<block
"definition" word-prop pprint-elements
- pprint-; block> ;
+ pprint-; block; t newline ;
M: tuple-class class.
- \ TUPLE: pprint-object bl
- dup pprint-object bl
+ \ TUPLE: pprint-word bl
+ dup pprint-word bl
"slot-names" word-prop [ f text bl ] each
- pprint-; ;
+ pprint-; t newline ;
M: word class. drop ;
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: unparser
-USING: alien generic kernel lists math memory namespaces parser
-sequences sequences stdio strings words ;
-
-GENERIC: unparse ( obj -- str )
-
-M: object unparse ( obj -- str )
- "( " swap class word-name " )" append3 ;
-
-: >digit ( n -- ch )
- dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
-
-: integer, ( num radix -- )
- dup >r /mod >digit , dup 0 > [
- r> integer,
- ] [
- r> 2drop
- ] ifte ;
-
-: >base ( num radix -- string )
- #! Convert a number to a string in a certain base.
- [
- over 0 < [
- swap neg swap integer, CHAR: - ,
- ] [
- integer,
- ] ifte
- ] make-rstring ;
-
-: >dec ( num -- string ) 10 >base ;
-: >bin ( num -- string ) 2 >base ;
-: >oct ( num -- string ) 8 >base ;
-: >hex ( num -- string ) 16 >base ;
-
-M: integer unparse ( obj -- str ) >dec ;
-
-M: ratio unparse ( num -- str )
- [
- dup
- numerator unparse %
- CHAR: / ,
- denominator unparse %
- ] make-string ;
-
-: fix-float ( str -- str )
- #! This is terrible. Will go away when we do our own float
- #! output.
- CHAR: . over member? [ ".0" append ] unless ;
-
-M: float unparse ( float -- str )
- (unparse-float) fix-float ;
-
-M: complex unparse ( num -- str )
- [
- "#{ " %
- dup
- real unparse %
- " " %
- imaginary unparse %
- " }#" %
- ] make-string ;
-
-: ch>ascii-escape ( ch -- esc )
- [
- [[ CHAR: \e "\\e" ]]
- [[ CHAR: \n "\\n" ]]
- [[ CHAR: \r "\\r" ]]
- [[ CHAR: \t "\\t" ]]
- [[ CHAR: \0 "\\0" ]]
- [[ CHAR: \\ "\\\\" ]]
- [[ CHAR: \" "\\\"" ]]
- ] assoc ;
-
-: ch>unicode-escape ( ch -- esc )
- >hex 4 CHAR: 0 pad-left "\\u" swap append ;
-
-: unparse-ch ( ch -- ch/str )
- dup quotable? [
- ,
- ] [
- dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?ifte %
- ] ifte ;
-
-: unparse-string [ unparse-ch ] each ;
-
-M: string unparse ( str -- str )
- [ CHAR: " , unparse-string CHAR: " , ] make-string ;
-
-M: sbuf unparse ( str -- str )
- [ "SBUF\" " % unparse-string CHAR: " , ] make-string ;
-
-M: word unparse ( obj -- str ) word-name dup "( unnamed )" ? ;
-
-M: t unparse drop "t" ;
-M: f unparse drop "f" ;
-
-M: dll unparse ( obj -- str )
- [ "DLL\" " % dll-path unparse-string CHAR: " , ] make-string ;
IN: temporary
-USING: parser prettyprint sequences io strings unparser ;
+USING: parser prettyprint sequences io strings ;
USE: hashtables
USE: namespaces
M: sequence testing 4 ;
[ [ 1 2 ] 2 ] [ [ 1 2 ] testing ] unit-test
-! Bootstrap hashing
-[ f ] [ \ f \ unparse "methods" word-prop hash not ] unit-test
-
GENERIC: union-containment
M: integer union-containment drop 1 ;
M: number union-containment drop 2 ;
[ [ 2 1 ] ] [ [ >= ] infer ] unit-test
[ [ 2 1 ] ] [ [ number= ] infer ] unit-test
-[ [ 1 1 ] ] [ [ str>number ] infer ] unit-test
+[ [ 1 1 ] ] [ [ string>number ] infer ] unit-test
[ [ 2 1 ] ] [ [ = ] infer ] unit-test
[ [ 1 1 ] ] [ [ get ] infer ] unit-test
IN: temporary
-USING: unparser ;
USE: vectors
USE: interpreter
USE: test
[ [ "hi" print ] string-out ] test-interpreter
] unit-test
-[ { "4\n" } ] [
- [ [ 2 2 + unparse print ] string-out ] test-interpreter
-] unit-test
-
[ { "4\n" } ] [
[ [ 2 2 + . ] string-out ] test-interpreter
] unit-test
IN: temporary
-USING: kernel math test unparser ;
+USING: kernel math prettyprint test ;
[ "-8" ] [ -8 unparse ] unit-test
USE: kernel
USE: math
USE: test
-USE: unparser
[ 1 2 ] [ 1/2 >fraction ] unit-test
IN: temporary
-USING: errors kernel math parser test unparser ;
+USING: errors kernel math parser test ;
: parse-number ( str -- num )
#! Convert a string to a number; return f on error.
- [ str>number ] [ [ drop f ] when ] catch ;
+ [ string>number ] [ [ drop f ] when ] catch ;
[ f ]
[ f parse-number ]
unit-test
[ "100.0" ]
-[ "1.0e2" parse-number unparse ]
+[ "1.0e2" parse-number number>string ]
unit-test
[ "-100.0" ]
-[ "-1.0e2" parse-number unparse ]
+[ "-1.0e2" parse-number number>string ]
unit-test
[ "0.01" ]
-[ "1.0e-2" parse-number unparse ]
+[ "1.0e-2" parse-number number>string ]
unit-test
[ "-0.01" ]
-[ "-1.0e-2" parse-number unparse ]
+[ "-1.0e-2" parse-number number>string ]
unit-test
[ f ]
unit-test
[ "3.14" ]
-[ "3.14" parse-number unparse ]
+[ "3.14" parse-number number>string ]
unit-test
[ f ]
unit-test
[ "101.0" ]
-[ "1.01e2" parse-number unparse ]
+[ "1.01e2" parse-number number>string ]
unit-test
[ "-101.0" ]
-[ "-1.01e2" parse-number unparse ]
+[ "-1.01e2" parse-number number>string ]
unit-test
[ "1.01" ]
-[ "101.0e-2" parse-number unparse ]
+[ "101.0e-2" parse-number number>string ]
unit-test
[ "-1.01" ]
-[ "-101.0e-2" parse-number unparse ]
+[ "-101.0e-2" parse-number number>string ]
unit-test
[ 5 ]
unit-test
[ "33/100" ]
-[ "66/200" parse-number unparse ]
+[ "66/200" parse-number number>string ]
unit-test
[ "12" bin> ] unit-test-fails
IN: temporary
USE: parser
USE: test
-USE: unparser
USE: lists
USE: kernel
USE: generic
IN: temporary
-USING: io kernel lists math prettyprint sequences test words ;
+USING: alien io kernel lists math prettyprint sequences
+test words inference namespaces vectors ;
-[ "4" ] [ 4 pprint>string ] unit-test
-[ "1.0" ] [ 1.0 pprint>string ] unit-test
-[ "#{ 1/2 2/3 }#" ] [ #{ 1/2 2/3 }# pprint>string ] unit-test
-[ "1267650600228229401496703205376" ] [ 1 100 shift pprint>string ] unit-test
+[ "4" ] [ 4 unparse ] unit-test
+[ "1.0" ] [ 1.0 unparse ] unit-test
+[ "#{ 1/2 2/3 }#" ] [ #{ 1/2 2/3 }# unparse ] unit-test
+[ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
-[ "+" ] [ \ + pprint>string ] unit-test
+[ "+" ] [ \ + unparse ] unit-test
-[ "\\ +" ] [ [ \ + ] first pprint>string ] unit-test
+[ "\\ +" ] [ [ \ + ] first unparse ] unit-test
-[ "1" ] [
- [ [ <block 1 pprint-object block> ] with-pprint ] string-out
-] unit-test
-
-[ "{ }" ] [ { } pprint>string ] unit-test
+[ "{ }" ] [ { } unparse ] unit-test
-[ "{ 1 2 3 }" ] [ { 1 2 3 } pprint>string ] unit-test
+[ "{ 1 2 3 }" ] [ { 1 2 3 } unparse ] unit-test
[ "\"hello\\\\backslash\"" ]
-[ "hello\\backslash" pprint>string ]
+[ "hello\\backslash" unparse ]
unit-test
[ "\"\\u1234\"" ]
-[ "\u1234" pprint>string ]
+[ "\u1234" unparse ]
unit-test
[ "\"\\e\"" ]
-[ "\e" pprint>string ]
+[ "\e" unparse ]
unit-test
-[ "f" ] [ f pprint>string ] unit-test
-[ "t" ] [ t pprint>string ] unit-test
+[ "f" ] [ f unparse ] unit-test
+[ "t" ] [ t unparse ] unit-test
-[ "SBUF\" hello world\"" ] [ SBUF" hello world" pprint>string ] unit-test
+[ "SBUF\" hello world\"" ] [ SBUF" hello world" unparse ] unit-test
: foo dup * ; inline
[ "IN: temporary\n: foo dup * ; inline\n" ]
[ [ \ foo see ] string-out ] unit-test
+: bar ( x -- y ) 2 + ;
+
+[ "IN: temporary\n: bar ( x -- y ) 2 + ;\n" ] [ [ \ bar see ] string-out ] unit-test
+
+: baz dup ;
+
+[ ] [ [ baz ] infer drop ] unit-test
+[ "IN: temporary\n: baz ( object -- object object ) dup ;\n" ]
+[ [ \ baz see ] string-out ] unit-test
+
[ ] [ \ fixnum see ] unit-test
[ ] [ \ integer see ] unit-test
[ ] [ \ compound see ] unit-test
[ ] [ \ pprinter see ] unit-test
+
+[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
+
+[ "{\n 5 5 5 5 5 5 5 5 5 5\n}" ]
+[
+ [
+ 4 tab-size set
+ 23 margin set
+ 10 5 <repeated> >vector unparse
+ ] with-scope
+] unit-test
IN: test
USING: errors kernel lists math memory namespaces parser
-prettyprint sequences io strings unparser vectors words ;
+prettyprint sequences io strings vectors words ;
TUPLE: assert got expect ;
#! execute it.
millis >r gc-time >r call gc-time r> - millis r> -
[
- unparse % " ms run / " % unparse % " ms GC time" %
+ number>string % " ms run / " %
+ number>string % " ms GC time" %
] make-string print ;
: unit-test ( output input -- )
"continuations" "errors" "hashtables" "strings"
"namespaces" "generic" "tuple" "files" "parser"
"parse-number" "init" "io/io"
- "listener" "vectors" "words" "unparser" "random"
+ "listener" "vectors" "words" "prettyprint" "random"
"stream" "math/bitops"
"math/math-combinators" "math/rational" "math/float"
"math/complex" "math/irrational" "math/integer"
! See http://factor.sf.net/license.txt for BSD license.
IN: errors
USING: generic kernel kernel-internals lists math namespaces
-parser prettyprint sequences io strings unparser
-vectors words ;
+parser prettyprint sequences io strings vectors words ;
: expired-error. ( obj -- )
"Object did not survive image save/load: " write . ;
"Parsing " write
dup parse-error-file [ "<interactive>" ] unless* write
":" write
- dup parse-error-line [ 1 ] unless* unparse print
+ dup parse-error-line [ 1 ] unless* number>string print
dup parse-error-text dup string? [ print ] [ drop ] ifte
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: words USING: kernel math namespaces sequences strings
-unparser ;
+IN: words USING: kernel math namespaces parser sequences strings ;
SYMBOL: gensym-count
: (gensym) ( -- name )
"G:" global [
gensym-count [ 1 + dup ] change
- ] bind unparse append ;
+ ] bind number>string append ;
: gensym ( -- word )
#! Return a word that is distinct from every other word, and
IN: inspector
USING: generic hashtables io kernel kernel-internals lists math
memory namespaces prettyprint sequences strings styles test
-unparser vectors words ;
+vectors words ;
SYMBOL: inspecting
dup class "slots" word-prop
[ second ] map
tuck [ execute ] map-with
- 2list ;
+ 2vector ;
M: list sheet unit ;
M: hashtable sheet dup hash-keys swap hash-values 2list ;
: format-column ( list -- list )
- [ pprint>short-string ] map
+ [ unparse-short ] map
[ max-length ] keep
[ swap CHAR: \s pad-right ] map-with ;
extra-banner ;
: describe ( obj -- )
- sheet dup format-sheet
- swap peek [ presented swons unit ] map
- [ format terpri ] 2each ;
+ sheet dup format-sheet swap peek
+ [ write-object terpri ] 2each ;
: inspect ( obj -- )
dup inspecting set dup inspect-banner describe ;
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: jedit
-USING: kernel lists namespaces parser sequences io strings
-unparser words ;
+USING: io kernel lists namespaces parser prettyprint sequences
+strings unparser vectors words ;
! Some words to send requests to a running jEdit instance to
! edit files and position the cursor on a specific line number.
: jedit-server-info ( -- port auth )
jedit-server-file <file-reader> [
readln drop
- readln str>number
- readln str>number
+ readln string>number
+ readln string>number
] with-stream ;
: make-jedit-request ( files params -- code )
[
- "EditServer.handleClient(false,false,false,null," %
- "new String[] {" %
- [ unparse % "," % ] each
- "null});\n" %
- ] make-string ;
+ "EditServer.handleClient(false,false,false,null," write
+ "new String[] {" write
+ [ pprint "," write ] each
+ "null});\n" write
+ ] string-out ;
: send-jedit-request ( request -- )
jedit-server-info swap "localhost" swap <client> [
] with-stream ;
: jedit-line/file ( file line -- )
- unparse "+line:" swap append 2list
+ number>string "+line:" swap append 2vector
make-jedit-request send-jedit-request ;
: jedit-file ( file -- )
- unit make-jedit-request send-jedit-request ;
+ 1vector make-jedit-request send-jedit-request ;
: jedit ( word -- )
#! Note that line numbers here start from 1
! See http://factor.sf.net/license.txt for BSD license.
IN: listener
USING: errors io kernel lists math memory namespaces parser
-presentation sequences strings styles unparser vectors words ;
+presentation sequences strings styles vectors words ;
SYMBOL: listener-prompt
SYMBOL: quit-flag
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: memory
-USING: errors generic hashtables kernel kernel-internals lists
-math namespaces prettyprint sequences io strings unparser
-vectors words ;
+USING: errors generic hashtables io kernel kernel-internals
+lists math namespaces parser prettyprint sequences strings
+unparser vectors words ;
: generations 15 getenv ;
! Printing an overview of heap usage.
-: kb. 1024 /i unparse 6 CHAR: \s pad-left write " KB" write ;
+: kb.
+ 1024 /i number>string
+ 6 CHAR: \s pad-left write
+ " KB" write ;
: (room.) ( free total -- )
2dup swap - swap ( free used total )
: room. ( -- )
room
0 swap [
- "Generation " write over unparse write ":" write
+ "Generation " write over pprint ":" write
uncons (room.) 1 +
] each drop
"Semi-space: " write kb. terpri
3drop
] [
rot type>class word-name write ": " write
- unparse write " bytes, " write
- unparse write " instances" print
+ pprint " bytes, " write
+ pprint " instances" print
] ifte ;
: heap-stats. ( -- )
IN: shells
: telnet
- "telnetd-port" get str>number telnetd ;
+ "telnetd-port" get string>number telnetd ;
-! This is a string since we str>number it above.
+! This is a string since we string>number it above.
global [ "9999" "telnetd-port" set ] bind
! See http://factor.sf.net/license.txt for BSD license.
IN: words
USING: generic inspector lists kernel namespaces
-prettyprint io strings sequences unparser math
-hashtables parser ;
+prettyprint io strings sequences math hashtables parser ;
: vocab-apropos ( substring vocab -- list )
#! Push a list of all words in a vocabulary whose names
[[ font-style plain ]]
}} world get set-gadget-paint
- { 640 768 0 } world get set-gadget-dim
+ { 700 800 0 } world get set-gadget-dim
<plain-gadget> add-layer
<pane> dup pane set <scroller>
<pane> dup stack-display set <scroller>
- 3/4 <x-splitter> add-layer
+ 5/6 <x-splitter> add-layer
[
pane get [
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: io-internals
-USING: alien assembler errors generic hashtables kernel
-kernel-internals lists math sequences io strings threads
-unix-internals unparser vectors ;
+USING: alien assembler errors generic hashtables io kernel
+kernel-internals lists math parser sequences strings threads
+unix-internals vectors ;
! We want namespaces::bind to shadow the bind system call from
! unix-internals
: report-error ( error port -- )
[
"Error on fd " %
- dup port-handle unparse %
+ dup port-handle number>string %
": " % swap %
] make-string swap set-port-error ;
! We need to fiddle with the exact search order here, since
! unix-internals::accept shadows streams::accept.
IN: io-internals
-USING: errors namespaces io threads unparser alien generic
-kernel math unix-internals ;
+USING: alien errors generic io kernel math namespaces parser
+threads unix-internals ;
: <socket-stream> ( fd -- stream )
dup f <fd-stream> ;
: inet-ntoa ( n -- str )
ntohl [
- dup -24 shift HEX: ff bitand unparse % CHAR: . ,
- dup -16 shift HEX: ff bitand unparse % CHAR: . ,
- dup -8 shift HEX: ff bitand unparse % CHAR: . ,
- HEX: ff bitand unparse %
+ dup -24 shift HEX: ff bitand number>string % CHAR: . ,
+ dup -16 shift HEX: ff bitand number>string % CHAR: . ,
+ dup -8 shift HEX: ff bitand number>string % CHAR: . ,
+ HEX: ff bitand number>string %
] make-string ;
: do-accept ( port sockaddr fd -- )
"jedit" "kernel" "listener" "lists" "math" "matrices"
"memory" "namespaces" "parser" "prettyprint"
"sequences" "io" "strings" "styles" "syntax" "test"
- "threads" "unparser" "vectors" "words" "scratchpad"
+ "threads" "vectors" "words" "scratchpad"
] "use" set ;
IN: win32-stream
USING: alien errors generic kernel kernel-internals lists math namespaces
- prettyprint sequences io strings threads unparser win32-api
+ prettyprint sequences io strings threads win32-api
win32-io-internals io-internals ;
TUPLE: win32-server this ;
projects / factor.git / commitdiff