- type inference\r
- some way to step over a word in the stepper\r
- step: print NEXT word to execute, not word that JUST executed\r
+- step: start a nested listener\r
\r
+ compiler/ffi:\r
\r
+ listener/plugin:\r
\r
- gracefully handle non-working cfactor\r
-- accept multi-line input in listener\r
- don't show listener on certain commands\r
- NPE in ErrorHighlight\r
- some way to not have previous definitions from a source file\r
clutter the namespace\r
- finish ExternalFactor VocabularyLookup\r
-- fedit broken with listener\r
- maple-like: press enter at old commands to evaluate there\r
- completion in the listener\r
- special completion for USE:/IN:\r
plugin.factor.jedit.FactorPlugin.depend.3=plugin console.ConsolePlugin 4.0.1
#! Menu
-plugin.factor.jedit.FactorPlugin.menu=factor-run-file \
+plugin.factor.jedit.FactorPlugin.menu=factor-listener \
+ - \
+ factor-run-file \
factor-eval-selection \
- \
factor-apropos \
- \
factor-restart
+factor-listener.label=Listener
factor-run-file.label=Run current file
factor-eval-selection.label=Evaluate selection
factor-apropos.label=Apropos at caret
USE: stdio
: eval-catch ( str -- )
- [ eval ] [ [ default-error-handler drop ] when* ] catch ;
+ [ eval ] print-error ;
: eval>string ( in -- out )
[ eval-catch ] with-string ;
[ write ] "fwrite" set
( string style -- )
[ write-attr ] "fwrite-attr" set
- ( string -- )
- [ edit ] "fedit" set
( -- )
[ flush ] "fflush" set
( -- )
"stdio" get "client" set log-client
read [ parse-request ] when*
] with-stream
- ] [
- [ default-error-handler drop ] when*
- ] catch ;
+ ] print-error ;
: httpd-connection ( socket -- )
"http-server" get accept [ httpd-client ] in-thread drop ;
"/library/platform/native/words.factor"
"/library/words.factor"
"/library/platform/native/vocabularies.factor"
- "/library/platform/native/parse-numbers.factor"
- "/library/platform/native/parser.factor"
- "/library/platform/native/parse-syntax.factor"
- "/library/platform/native/parse-stream.factor"
+ "/library/syntax/parse-numbers.factor"
+ "/library/syntax/parser.factor"
+ "/library/syntax/parse-syntax.factor"
+ "/library/syntax/parse-stream.factor"
"/library/format.factor"
- "/library/platform/native/unparser.factor"
+ "/library/syntax/unparser.factor"
"/library/presentation.factor"
"/library/vocabulary-style.factor"
- "/library/prettyprint.factor"
+ "/library/syntax/prettyprint.factor"
"/library/platform/native/debugger.factor"
"/library/tools/debugger.factor"
"/library/platform/native/init.factor"
"/library/platform/native/random.factor"
"/library/random.factor"
"/library/stdio-binary.factor"
- "/library/platform/native/prettyprint.factor"
"/library/platform/native/files.factor"
"/library/files.factor"
"/library/eval-catch.factor"
"/library/platform/native/words.factor"
"/library/words.factor"
"/library/platform/native/vocabularies.factor"
- "/library/platform/native/parse-numbers.factor"
- "/library/platform/native/parser.factor"
- "/library/platform/native/parse-syntax.factor"
- "/library/platform/native/parse-stream.factor"
+ "/library/syntax/parse-numbers.factor"
+ "/library/syntax/parser.factor"
+ "/library/syntax/parse-syntax.factor"
+ "/library/syntax/parse-stream.factor"
"/library/platform/native/math.factor"
"/library/platform/native/init.factor"
] [
! Clear stacks since we never go up from this point
{ } set-catchstack
{ } set-callstack
- [
- call
- ] [
- [ default-error-handler drop ] when*
- ] catch
+ print-error
(yield)
] callcc0 drop ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: parser
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: stack
-USE: strings
-USE: words
-USE: unparser
-
-! Number parsing
-
-: not-a-number "Not a number" throw ;
-
-: digit> ( ch -- n )
- [
- [ digit? ] [ CHAR: 0 - ]
- [ letter? ] [ CHAR: a - 10 + ]
- [ LETTER? ] [ CHAR: A - 10 + ]
- [ drop t ] [ not-a-number ]
- ] cond ;
-
-: digit ( num digit base -- num )
- 2dup < [ rot * + ] [ not-a-number ] ifte ;
-
-: (base>) ( base str -- num )
- dup str-length 0 = [
- not-a-number
- ] [
- 0 swap [ digit> pick digit ] str-each nip
- ] ifte ;
-
-: base> ( str base -- num )
- #! Convert a string to an integer. Throw an error if
- #! conversion fails.
- swap "-" ?str-head [ (base>) neg ] [ (base>) ] ifte ;
-
-: str>ratio ( str -- num )
- dup CHAR: / index-of str// swap 10 base> swap 10 base> / ;
-
-: str>number ( str -- num )
- #! Convert a string to a number; throws errors.
- [
- [ "/" swap str-contains? ] [ str>ratio ]
- [ "." swap str-contains? ] [ str>float ]
- [ drop t ] [ 10 base> ]
- ] cond ;
-
-: parse-number ( str -- num )
- #! Convert a string to a number; return f on error.
- [ str>number ] [ [ drop f ] when ] catch ;
-
-: bin> 2 base> ;
-: oct> 8 base> ;
-: dec> 10 base> ;
-: hex> 16 base> ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: parser
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: math
-USE: namespaces
-USE: stack
-USE: stdio
-USE: streams
-USE: strings
-
-! Stream parsing uses a number of variables:
-! file
-! line-number
-! parse-stream
-
-: next-line ( -- str )
- "parse-stream" get freadln
- "line-number" succ@ ;
-
-: (read-lines) ( quot -- )
- next-line dup [
- swap dup >r call r> (read-lines)
- ] [
- 2drop
- ] ifte ;
-
-: read-lines ( stream quot -- )
- #! 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 ;
-
-: file-vocabs ( -- )
- "file-in" get "in" set
- "file-use" get "use" set ;
-
-: (parse-stream) ( name stream -- quot )
- #! Uses the current namespace for temporary variables.
- >r "file" set f r>
- [ (parse) ] read-lines reverse
- "file" off
- "line-number" off ;
-
-: parse-stream ( name stream -- quot )
- [ file-vocabs (parse-stream) ] with-scope ;
-
-: parse-file ( file -- quot )
- dup <filecr> parse-stream ;
-
-: run-file ( file -- )
- #! Run a file. The file is read with the default IN:/USE:
- #! for files.
- parse-file call ;
-
-: (parse-file) ( file -- quot )
- dup <filecr> (parse-stream) ;
-
-: (run-file) ( file -- )
- #! Run a file. The file is read with the same IN:/USE: as
- #! the current interactive interpreter.
- (parse-file) call ;
-
-: parse-resource ( path -- quot )
- #! Resources are loaded from the resource-path variable, or
- #! the current directory if it is not set. Words defined in
- #! resources have a definition source path starting with
- #! resource:. This allows words that operate on source
- #! files, like "jedit", to use a different resource path
- #! at run time than was used at parse time.
- "resource:" over cat2 swap <resource-stream> parse-stream ;
-
-: run-resource ( file -- )
- parse-resource call ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: parser
-
-USE: combinators
-USE: errors
-USE: hashtables
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: stack
-USE: strings
-USE: words
-USE: vectors
-USE: unparser
-
-! Colon defs
-: CREATE ( -- word )
- scan "in" get create dup set-word
- dup f "documentation" set-word-property
- dup f "stack-effect" set-word-property
- dup "line-number" get "line" set-word-property
- dup "col" get "col" set-word-property
- dup "file" get "file" set-word-property ;
-
-! \x
-: unicode-escape>ch ( -- esc )
- #! Read \u....
- next-ch digit> 16 *
- next-ch digit> + 16 *
- next-ch digit> + 16 *
- next-ch digit> + ;
-
-: ascii-escape>ch ( ch -- esc )
- [
- [ CHAR: e | CHAR: \e ]
- [ CHAR: n | CHAR: \n ]
- [ CHAR: r | CHAR: \r ]
- [ CHAR: t | CHAR: \t ]
- [ CHAR: s | CHAR: \s ]
- [ CHAR: \s | CHAR: \s ]
- [ CHAR: 0 | CHAR: \0 ]
- [ CHAR: \\ | CHAR: \\ ]
- [ CHAR: \" | CHAR: \" ]
- ] assoc ;
-
-: escape ( ch -- esc )
- dup CHAR: u = [
- drop unicode-escape>ch
- ] [
- ascii-escape>ch
- ] ifte ;
-
-: parse-escape ( -- )
- next-ch escape dup [ drop "Bad escape" throw ] unless ;
-
-: parse-ch ( ch -- ch )
- dup CHAR: \\ = [ drop parse-escape ] when ;
-
-: doc-comment-here? ( parsed -- ? )
- not "in-definition" get and ;
-
-: parsed-stack-effect ( parsed str -- parsed )
- over doc-comment-here? [
- word stack-effect [
- drop
- ] [
- word swap "stack-effect" set-word-property
- ] ifte
- ] [
- drop
- ] ifte ;
-
-: documentation+ ( word str -- )
- over "documentation" word-property [
- swap "\n" swap cat3
- ] when*
- "documentation" set-word-property ;
-
-: parsed-documentation ( parsed str -- parsed )
- over doc-comment-here? [
- word swap documentation+
- ] [
- drop
- ] ifte ;
-
-IN: syntax
-
-: inline ( -- )
- #! Mark the last word to be inlined.
- word t "inline" set-word-property ; parsing
-
-! The variable "in-definition" is set inside a : ... ;.
-! ( and #! then add "stack-effect" and "documentation"
-! properties to the current word if it is set.
-
-! Constants
-: t t parsed ; parsing
-: f f parsed ; parsing
-
-! Lists
-: [ f ; parsing
-: ] reverse parsed ; parsing
-
-: | ( syntax: | cdr ] )
- #! See the word 'parsed'. We push a special sentinel, and
- #! 'parsed' acts accordingly.
- "|" ; parsing
-
-! Vectors
-: { f ; parsing
-: } reverse list>vector parsed ; parsing
-
-! Hashtables
-: {{ f ; parsing
-: }} alist>hash parsed ; parsing
-
-! Do not execute parsing word
-: POSTPONE: ( -- ) scan-word parsed ; parsing
-
-: :
- #! Begin a word definition. Word name follows.
- CREATE [ ] "in-definition" on ; parsing
-
-: ;-hook ( word def -- )
- ";-hook" get [ call ] [ define-compound ] ifte* ;
-
-: ;
- #! End a word definition.
- "in-definition" off reverse ;-hook ; parsing
-
-! Symbols
-: SYMBOL: CREATE define-symbol ; parsing
-
-: \
- #! Parsed as a piece of code that pushes a word on the stack
- #! \ foo ==> [ foo ] car
- scan-word unit parsed \ car parsed ; parsing
-
-! Vocabularies
-: DEFER: CREATE drop ; parsing
-: USE: scan "use" cons@ ; parsing
-: IN: scan dup "use" cons@ "in" set ; parsing
-
-! Char literal
-: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
-
-! String literal
-: parse-string ( -- )
- next-ch dup CHAR: " = [
- drop
- ] [
- parse-ch , parse-string
- ] ifte ;
-
-: "
- #! Note the ugly hack to carry the new value of 'pos' from
- #! the make-string scope up to the original scope.
- [ parse-string "col" get ] make-string
- swap "col" set parsed ; parsing
-
-! Complex literal
-: #{
- #! Read #{ real imaginary #}
- scan str>number scan str>number rect> "}" expect parsed ;
- parsing
-
-! Comments
-: ( ")" until parsed-stack-effect ; parsing
-
-: ! until-eol drop ; parsing
-
-: #! until-eol parsed-documentation ; parsing
-
-! Reading numbers in other bases
-
-: BASE: ( base -- )
- #! Read a number in a specific base.
- scan swap base> parsed ;
-
-: HEX: 16 BASE: ; parsing
-: DEC: 10 BASE: ; parsing
-: OCT: 8 BASE: ; parsing
-: BIN: 2 BASE: ; parsing
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: parser
-USE: combinators
-USE: errors
-USE: kernel
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: stack
-USE: strings
-USE: words
-USE: unparser
-
-! The parser uses a number of variables:
-! line - the line being parsed
-! pos - position in the line
-! use - list of vocabularies
-! in - vocabulary for new words
-!
-! When a token is scanned, it is searched for in the 'use' list
-! of vocabularies. If it is a parsing word, it is executed
-! immediately. Otherwise it is appended to the parse tree.
-
-: parsing? ( word -- ? )
- dup word? [
- "parsing" word-property
- ] [
- drop f
- ] ifte ;
-
-: end? ( -- ? )
- "col" get "line" get str-length >= ;
-
-: (with-parser) ( quot -- )
- end? [ drop ] [ [ call ] keep (with-parser) ] ifte ;
-
-: with-parser ( text quot -- )
- #! Keep calling the quotation until we reach the end of the
- #! input.
- swap "line" set 0 "col" set
- (with-parser)
- "line" off "col" off ;
-
-: ch ( -- ch ) "col" get "line" get str-nth ;
-: advance ( -- ) "col" succ@ ;
-
-: skip ( n line quot -- n )
- #! Find the next character that satisfies the quotation,
- #! which should have stack effect ( ch -- ? ).
- >r 2dup str-length < [
- 2dup str-nth r> dup >r call [
- r> 2drop
- ] [
- >r succ r> r> skip
- ] ifte
- ] [
- r> drop nip str-length
- ] ifte ;
-
-: skip-blank ( n line -- n )
- [ blank? not ] skip ;
-
-: skip-word ( n line -- n )
- [ blank? ] skip ;
-
-: denotation? ( ch -- ? )
- #! Hard-coded for now. Make this customizable later.
- #! A 'denotation' is a character that is treated as its
- #! own word, eg:
- #!
- #! "hello world"
- #!
- #! Will call the parsing word ".
- "\"" str-contains? ;
-
-: (scan) ( n line -- start end )
- dup >r skip-blank dup r>
- 2dup str-length < [
- 2dup str-nth denotation? [
- drop succ
- ] [
- skip-word
- ] ifte
- ] [
- drop
- ] ifte ;
-
-: scan ( -- token )
- "col" get "line" get dup >r (scan) dup "col" set
- 2dup = [
- r> 3drop f
- ] [
- r> substring
- ] ifte ;
-
-: scan-word ( -- obj )
- scan dup [
- dup "use" get search dup [
- nip
- ] [
- drop str>number
- ] ifte
- ] when ;
-
-: parsed| ( parsed parsed obj -- parsed )
- #! Some ugly ugly code to handle [ a | b ] expressions.
- >r unswons r> cons swap [ swons ] each swons ;
-
-: expect ( word -- )
- dup scan = not [
- "Expected " swap cat2 throw
- ] [
- drop
- ] ifte ;
-
-: parsed ( obj -- )
- over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ;
-
-: (parse) ( str -- )
- [
- scan-word [
- dup parsing? [ execute ] [ parsed ] ifte
- ] when*
- ] with-parser ;
-
-: parse ( str -- code )
- #! Parse the string into a parse tree that can be executed.
- f swap (parse) reverse ;
-
-: eval ( "X" -- X )
- parse call ;
-
-! Used by parsing words
-: ch-search ( ch -- index )
- "col" get "line" get rot index-of* ;
-
-: (until) ( index -- str )
- "col" get swap dup succ "col" set "line" get substring ;
-
-: until ( ch -- str )
- ch-search (until) ;
-
-: (until-eol) ( -- index )
- "\n" ch-search dup -1 = [ drop "line" get str-length ] when ;
-
-: until-eol ( -- str )
- #! This is just a hack to get "eval" to work with multiline
- #! strings from jEdit with EOL comments. Normally, input to
- #! the parser is already line-tokenized.
- (until-eol) (until) ;
-
-: next-ch ( -- ch )
- end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ;
-
-: next-word-ch ( -- ch )
- "col" get "line" get skip-blank "col" set next-ch ;
-
-IN: syntax
-
-: parsing ( -- )
- #! Mark the most recently defined word to execute at parse
- #! time, rather than run time. The word can use 'scan' to
- #! read ahead in the input stream.
- word t "parsing" set-word-property ;
-
-! Once this file has loaded, we can use 'parsing' normally.
-! This hack is needed because in Java Factor, 'parsing' is
-! not parsing, but in CFactor, it is.
-\ parsing t "parsing" set-word-property
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: prettyprint
-USE: combinators
-USE: lists
-USE: parser
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: strings
-USE: unparser
-USE: words
-
-: stack-effect. ( word -- )
- stack-effect [
- " " write
- [ CHAR: ( , , CHAR: ) , ] make-string prettyprint-comment
- ] when* ;
-
-: documentation. ( indent word -- indent )
- documentation [
- "\n" split [
- "#!" swap cat2 prettyprint-comment
- dup prettyprint-newline
- ] each
- ] when* ;
-
-: prettyprint-docs ( indent word -- indent )
- [
- stack-effect. dup prettyprint-newline
- ] keep documentation. ;
-
-: see-compound ( word -- )
- 0 swap
- [ dupd prettyprint-IN: prettyprint-: ] keep
- [ prettyprint-word ] keep
- [ prettyprint-docs ] keep
- [ word-parameter prettyprint-list prettyprint-; ] keep
- prettyprint-plist prettyprint-newline ;
-
-: see-primitive ( word -- )
- "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
-
-: see-symbol ( word -- )
- "SYMBOL: " write . ;
-
-: see-undefined ( word -- )
- drop "Not defined" print ;
-
-: see ( name -- )
- #! Show a word definition.
- [
- [ compound? ] [ see-compound ]
- [ symbol? ] [ see-symbol ]
- [ primitive? ] [ see-primitive ]
- [ word? ] [ see-undefined ]
- [ drop t ] [ "Not a word: " write . ]
- ] cond ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: unparser
-USE: combinators
-USE: kernel
-USE: format
-USE: lists
-USE: logic
-USE: math
-USE: namespaces
-USE: parser
-USE: stack
-USE: stdio
-USE: strings
-USE: words
-
-: >digit ( n -- ch )
- dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
-
-: integer, ( num radix -- )
- tuck /mod >digit , dup 0 > [
- swap integer,
- ] [
- 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 ;
-
-DEFER: unparse
-
-: unparse-ratio ( num -- str )
- [
- dup
- numerator unparse ,
- CHAR: / ,
- denominator unparse ,
- ] make-string ;
-
-: unparse-complex ( 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 digits "\\u" swap cat2 ;
-
-: unparse-ch ( ch -- ch/str )
- dup quotable? [
- dup ch>ascii-escape dup [
- nip
- ] [
- drop ch>unicode-escape
- ] ifte
- ] unless ;
-
-: unparse-str ( str -- str )
- [
- CHAR: " , [ unparse-ch , ] str-each CHAR: " ,
- ] make-string ;
-
-: unparse-word ( word -- str )
- word-name dup "#<unnamed>" ? ;
-
-: fix-float ( str -- str )
- #! This is terrible. Will go away when we do our own float
- #! output.
- "." over str-contains? [ ".0" cat2 ] unless ;
-
-: unparse-float ( float -- str ) (unparse-float) fix-float ;
-
-: unparse-unknown ( obj -- str )
- [
- "#<" ,
- dup type type-name ,
- " @ " ,
- address unparse ,
- ">" ,
- ] make-string ;
-
-: unparse-t drop "t" ;
-: unparse-f drop "f" ;
-
-: unparse ( obj -- str )
- {
- >dec
- unparse-word
- unparse-unknown
- unparse-unknown
- unparse-ratio
- unparse-complex
- unparse-f
- unparse-t
- unparse-unknown
- >dec
- unparse-float
- unparse-unknown
- unparse-str
- unparse-unknown
- unparse-unknown
- unparse-unknown
- unparse-unknown
- } generic ;
: primitive? ( obj -- ? ) ?word-primitive 2 > ;
: symbol? ( obj -- ? ) ?word-primitive 2 = ;
-: comment?
- #! Comments are not first-class objects in CFactor.
- drop f ;
-
: word ( -- word ) global [ "last-word" get ] bind ;
: set-word ( word -- ) global [ "last-word" set ] bind ;
+++ /dev/null
-! :folding=indent:collapseFolds=1:
-
-! $Id$
-!
-! Copyright (C) 2003, 2004 Slava Pestov.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: prettyprint
-USE: combinators
-USE: errors
-USE: format
-USE: kernel
-USE: logic
-USE: lists
-USE: math
-USE: namespaces
-USE: prettyprint
-USE: stack
-USE: stdio
-USE: strings
-USE: presentation
-USE: unparser
-USE: vectors
-USE: words
-
-: tab-size
- #! Change this to suit your tastes.
- 4 ;
-
-: prettyprint-limit ( -- limit )
- #! Avoid infinite loops -- maximum indent, 10 levels.
- "prettyprint-limit" get [ 40 ] unless* ;
-
-: prettyprint-indent ( indent -- )
- #! Print the given number of spaces.
- " " fill write ;
-
-: prettyprint-newline ( indent -- )
- "\n" write prettyprint-indent ;
-
-: prettyprint-space ( -- )
- " " write ;
-
-: 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 ;
-
-: <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 ].
- [
- uncons >r prettyprint-element r>
- dup cons? [
- prettyprint-list
- ] [
- [
- "|" write prettyprint-space prettyprint-element
- ] when*
- ] ifte
- ] when* ;
-
-: prettyprint-[] ( indent list -- indent )
- swap prettyprint-[ swap prettyprint-list prettyprint-] ;
-
-: prettyprint-{ ( indent -- indent )
- "{" write <prettyprint ;
-
-: prettyprint-} ( indent -- indent )
- prettyprint> "}" write ;
-
-: prettyprint-vector ( indent list -- indent )
- #! Pretty-print a vector, without { and }.
- [ prettyprint-element ] vector-each ;
-
-: prettyprint-{} ( indent vector -- indent )
- dup vector-length 0 = [
- drop "{ }" write
- ] [
- swap prettyprint-{ swap prettyprint-vector prettyprint-}
- ] ifte ;
-
-: trim-newline ( str -- str )
- dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
-
-: prettyprint-comment ( comment -- )
- trim-newline "comments" style write-attr ;
-
-: word-link ( word -- link )
- [
- "vocabularies'" ,
- dup word-vocabulary ,
- "'" ,
- word-name ,
- ] make-string ;
-
-: word-actions ( -- list )
- [
- [ "Describe" | "describe-path" ]
- [ "Push" | "lookup" ]
- [ "Execute" | "lookup execute" ]
- [ "jEdit" | "lookup jedit" ]
- [ "Usages" | "lookup usages." ]
- ] ;
-
-: word-attrs ( word -- attrs )
- #! Words without a vocabulary do not get a link or an action
- #! popup.
- dup word-vocabulary [
- word-link [ "object-link" swons ] keep
- word-actions <actions> "actions" swons
- t "underline" swons
- 3list
- ] [
- drop [ ]
- ] ifte ;
-
-: prettyprint-word ( word -- )
- dup word-name
- swap dup word-attrs swap word-style append
- write-attr ;
-
-: prettyprint-object ( indent obj -- indent )
- unparse write ;
-
-: prettyprint* ( indent obj -- indent )
- over prettyprint-limit >= [
- unparse write
- ] [
- [
- [ f = ] [ prettyprint-object ]
- [ cons? ] [ prettyprint-[] ]
- [ vector? ] [ prettyprint-{} ]
- [ comment? ] [ prettyprint-comment ]
- [ word? ] [ prettyprint-word ]
- [ drop t ] [ prettyprint-object ]
- ] cond
- ] ifte ;
-
-: prettyprint ( obj -- )
- 0 swap prettyprint* drop terpri ;
-
-: vocab-link ( vocab -- link )
- "vocabularies'" swap cat2 ;
-
-: vocab-attrs ( word -- attrs )
- vocab-link "object-link" default-style acons ;
-
-: prettyprint-vocab ( vocab -- )
- dup vocab-attrs write-attr ;
-
-: prettyprint-IN: ( indent word -- )
- \ IN: prettyprint-word prettyprint-space
- word-vocabulary prettyprint-vocab prettyprint-newline ;
-
-: prettyprint-: ( indent -- indent )
- \ : prettyprint-word prettyprint-space
- tab-size + ;
-
-: prettyprint-; ( indent -- indent )
- \ ; prettyprint-word
- tab-size - ;
-
-: prettyprint-plist ( word -- )
- dup "parsing" word-property [ " parsing" write ] when
- "inline" word-property [ " inline" write ] when ;
-
-: . ( obj -- )
- [
- "prettyprint-single-line" on
- tab-size 4 * "prettyprint-limit" set
- prettyprint
- ] with-scope ;
-
-: [.] ( list -- )
- #! Unparse each element on its own line.
- [ . ] each ;
-
-: {.} ( vector -- )
- #! Unparse each element on its own line.
- stack>list [ . ] each ;
-
-: .n namestack [.] ;
-: .s datastack {.} ;
-: .r callstack {.} ;
-: .c catchstack {.} ;
-
-! For integers only
-: .b >bin print ;
-: .o >oct print ;
-: .h >hex print ;
: print ( string -- )
"stdio" get fprint ;
-: edit ( string -- )
- "stdio" get fedit ;
-
: terpri ( -- )
#! Print a newline to standard output.
"\n" write ;
#! Supported keys depend on the type of stream.
[ "fwrite-attr" get call ] bind ;
-: fedit ( string stream -- )
- [ "fedit" get call ] bind ;
-
: fclose ( stream -- )
[ "fclose" get call ] bind ;
[ "fwrite not implemented." throw ] "fwrite" set
( string style -- )
[ drop namespace fwrite ] "fwrite-attr" set
- ( string -- )
- [ "fedit not implemented." throw ] "fedit" set
( -- )
[ ] "fflush" set
( -- )
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: parser
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: words
+USE: unparser
+
+! Number parsing
+
+: not-a-number "Not a number" throw ;
+
+: digit> ( ch -- n )
+ [
+ [ digit? ] [ CHAR: 0 - ]
+ [ letter? ] [ CHAR: a - 10 + ]
+ [ LETTER? ] [ CHAR: A - 10 + ]
+ [ drop t ] [ not-a-number ]
+ ] cond ;
+
+: digit ( num digit base -- num )
+ 2dup < [ rot * + ] [ not-a-number ] ifte ;
+
+: (base>) ( base str -- num )
+ dup str-length 0 = [
+ not-a-number
+ ] [
+ 0 swap [ digit> pick digit ] str-each nip
+ ] ifte ;
+
+: base> ( str base -- num )
+ #! Convert a string to an integer. Throw an error if
+ #! conversion fails.
+ swap "-" ?str-head [ (base>) neg ] [ (base>) ] ifte ;
+
+: str>ratio ( str -- num )
+ dup CHAR: / index-of str// swap 10 base> swap 10 base> / ;
+
+: str>number ( str -- num )
+ #! Convert a string to a number; throws errors.
+ [
+ [ "/" swap str-contains? ] [ str>ratio ]
+ [ "." swap str-contains? ] [ str>float ]
+ [ drop t ] [ 10 base> ]
+ ] cond ;
+
+: parse-number ( str -- num )
+ #! Convert a string to a number; return f on error.
+ [ str>number ] [ [ drop f ] when ] catch ;
+
+: bin> 2 base> ;
+: oct> 8 base> ;
+: dec> 10 base> ;
+: hex> 16 base> ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: parser
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: stack
+USE: stdio
+USE: streams
+USE: strings
+
+! Stream parsing uses a number of variables:
+! file
+! line-number
+! parse-stream
+
+: next-line ( -- str )
+ "parse-stream" get freadln
+ "line-number" succ@ ;
+
+: (read-lines) ( quot -- )
+ next-line dup [
+ swap dup >r call r> (read-lines)
+ ] [
+ 2drop
+ ] ifte ;
+
+: read-lines ( stream quot -- )
+ #! 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 ;
+
+: file-vocabs ( -- )
+ "file-in" get "in" set
+ "file-use" get "use" set ;
+
+: (parse-stream) ( name stream -- quot )
+ #! Uses the current namespace for temporary variables.
+ >r "file" set f ( initial parse tree ) r>
+ [ (parse) ] read-lines reverse
+ "file" off
+ "line-number" off ;
+
+: parse-stream ( name stream -- quot )
+ [ file-vocabs (parse-stream) ] with-scope ;
+
+: parse-file ( file -- quot )
+ dup <filecr> parse-stream ;
+
+: run-file ( file -- )
+ #! Run a file. The file is read with the default IN:/USE:
+ #! for files.
+ parse-file call ;
+
+: (parse-file) ( file -- quot )
+ dup <filecr> (parse-stream) ;
+
+: (run-file) ( file -- )
+ #! Run a file. The file is read with the same IN:/USE: as
+ #! the current interactive interpreter.
+ (parse-file) call ;
+
+: parse-resource ( path -- quot )
+ #! Resources are loaded from the resource-path variable, or
+ #! the current directory if it is not set. Words defined in
+ #! resources have a definition source path starting with
+ #! resource:. This allows words that operate on source
+ #! files, like "jedit", to use a different resource path
+ #! at run time than was used at parse time.
+ "resource:" over cat2 swap <resource-stream> parse-stream ;
+
+: run-resource ( file -- )
+ parse-resource call ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: parser
+
+USE: combinators
+USE: errors
+USE: hashtables
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: words
+USE: vectors
+USE: unparser
+
+! Colon defs
+: CREATE ( -- word )
+ scan "in" get create dup set-word
+ dup f "documentation" set-word-property
+ dup f "stack-effect" set-word-property
+ dup "line-number" get "line" set-word-property
+ dup "col" get "col" set-word-property
+ dup "file" get "file" set-word-property ;
+
+! \x
+: unicode-escape>ch ( -- esc )
+ #! Read \u....
+ next-ch digit> 16 *
+ next-ch digit> + 16 *
+ next-ch digit> + 16 *
+ next-ch digit> + ;
+
+: ascii-escape>ch ( ch -- esc )
+ [
+ [ CHAR: e | CHAR: \e ]
+ [ CHAR: n | CHAR: \n ]
+ [ CHAR: r | CHAR: \r ]
+ [ CHAR: t | CHAR: \t ]
+ [ CHAR: s | CHAR: \s ]
+ [ CHAR: \s | CHAR: \s ]
+ [ CHAR: 0 | CHAR: \0 ]
+ [ CHAR: \\ | CHAR: \\ ]
+ [ CHAR: \" | CHAR: \" ]
+ ] assoc ;
+
+: escape ( ch -- esc )
+ dup CHAR: u = [
+ drop unicode-escape>ch
+ ] [
+ ascii-escape>ch
+ ] ifte ;
+
+: parse-escape ( -- )
+ next-ch escape dup [ drop "Bad escape" throw ] unless ;
+
+: parse-ch ( ch -- ch )
+ dup CHAR: \\ = [ drop parse-escape ] when ;
+
+: doc-comment-here? ( parsed -- ? )
+ not "in-definition" get and ;
+
+: parsed-stack-effect ( parsed str -- parsed )
+ over doc-comment-here? [
+ word stack-effect [
+ drop
+ ] [
+ word swap "stack-effect" set-word-property
+ ] ifte
+ ] [
+ drop
+ ] ifte ;
+
+: documentation+ ( word str -- )
+ over "documentation" word-property [
+ swap "\n" swap cat3
+ ] when*
+ "documentation" set-word-property ;
+
+: parsed-documentation ( parsed str -- parsed )
+ over doc-comment-here? [
+ word swap documentation+
+ ] [
+ drop
+ ] ifte ;
+
+IN: syntax
+
+: inline ( -- )
+ #! Mark the last word to be inlined.
+ word t "inline" set-word-property ; parsing
+
+! The variable "in-definition" is set inside a : ... ;.
+! ( and #! then add "stack-effect" and "documentation"
+! properties to the current word if it is set.
+
+! Constants
+: t t parsed ; parsing
+: f f parsed ; parsing
+
+! Lists
+: [ f ; parsing
+: ] reverse parsed ; parsing
+
+: | ( syntax: | cdr ] )
+ #! See the word 'parsed'. We push a special sentinel, and
+ #! 'parsed' acts accordingly.
+ "|" ; parsing
+
+! Vectors
+: { f ; parsing
+: } reverse list>vector parsed ; parsing
+
+! Hashtables
+: {{ f ; parsing
+: }} alist>hash parsed ; parsing
+
+! Do not execute parsing word
+: POSTPONE: ( -- ) scan-word parsed ; parsing
+
+: :
+ #! Begin a word definition. Word name follows.
+ CREATE [ ] "in-definition" on ; parsing
+
+: ;-hook ( word def -- )
+ ";-hook" get [ call ] [ define-compound ] ifte* ;
+
+: ;
+ #! End a word definition.
+ "in-definition" off reverse ;-hook ; parsing
+
+! Symbols
+: SYMBOL: CREATE define-symbol ; parsing
+
+: \
+ #! Parsed as a piece of code that pushes a word on the stack
+ #! \ foo ==> [ foo ] car
+ scan-word unit parsed \ car parsed ; parsing
+
+! Vocabularies
+: DEFER: CREATE drop ; parsing
+: USE: scan "use" cons@ ; parsing
+: IN: scan dup "use" cons@ "in" set ; parsing
+
+! Char literal
+: CHAR: ( -- ) next-word-ch parse-ch parsed ; parsing
+
+! String literal
+: parse-string ( -- )
+ next-ch dup CHAR: " = [
+ drop
+ ] [
+ parse-ch , parse-string
+ ] ifte ;
+
+: "
+ #! Note the ugly hack to carry the new value of 'pos' from
+ #! the make-string scope up to the original scope.
+ [ parse-string "col" get ] make-string
+ swap "col" set parsed ; parsing
+
+! Complex literal
+: #{
+ #! Read #{ real imaginary #}
+ scan str>number scan str>number rect> "}" expect parsed ;
+ parsing
+
+! Comments
+: ( ")" until parsed-stack-effect ; parsing
+
+: ! until-eol drop ; parsing
+
+: #! until-eol parsed-documentation ; parsing
+
+! Reading numbers in other bases
+
+: BASE: ( base -- )
+ #! Read a number in a specific base.
+ scan swap base> parsed ;
+
+: HEX: 16 BASE: ; parsing
+: DEC: 10 BASE: ; parsing
+: OCT: 8 BASE: ; parsing
+: BIN: 2 BASE: ; parsing
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: parser
+USE: combinators
+USE: errors
+USE: kernel
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: stack
+USE: strings
+USE: words
+USE: unparser
+
+! The parser uses a number of variables:
+! line - the line being parsed
+! pos - position in the line
+! use - list of vocabularies
+! in - vocabulary for new words
+!
+! When a token is scanned, it is searched for in the 'use' list
+! of vocabularies. If it is a parsing word, it is executed
+! immediately. Otherwise it is appended to the parse tree.
+
+: parsing? ( word -- ? )
+ dup word? [
+ "parsing" word-property
+ ] [
+ drop f
+ ] ifte ;
+
+: end? ( -- ? )
+ "col" get "line" get str-length >= ;
+
+: (with-parser) ( quot -- )
+ end? [ drop ] [ [ call ] keep (with-parser) ] ifte ;
+
+: with-parser ( text quot -- )
+ #! Keep calling the quotation until we reach the end of the
+ #! input.
+ swap "line" set 0 "col" set
+ (with-parser)
+ "line" off "col" off ;
+
+: ch ( -- ch ) "col" get "line" get str-nth ;
+: advance ( -- ) "col" succ@ ;
+
+: skip ( n line quot -- n )
+ #! Find the next character that satisfies the quotation,
+ #! which should have stack effect ( ch -- ? ).
+ >r 2dup str-length < [
+ 2dup str-nth r> dup >r call [
+ r> 2drop
+ ] [
+ >r succ r> r> skip
+ ] ifte
+ ] [
+ r> drop nip str-length
+ ] ifte ;
+
+: skip-blank ( n line -- n )
+ [ blank? not ] skip ;
+
+: skip-word ( n line -- n )
+ [ blank? ] skip ;
+
+: denotation? ( ch -- ? )
+ #! Hard-coded for now. Make this customizable later.
+ #! A 'denotation' is a character that is treated as its
+ #! own word, eg:
+ #!
+ #! "hello world"
+ #!
+ #! Will call the parsing word ".
+ "\"" str-contains? ;
+
+: (scan) ( n line -- start end )
+ dup >r skip-blank dup r>
+ 2dup str-length < [
+ 2dup str-nth denotation? [
+ drop succ
+ ] [
+ skip-word
+ ] ifte
+ ] [
+ drop
+ ] ifte ;
+
+: scan ( -- token )
+ "col" get "line" get dup >r (scan) dup "col" set
+ 2dup = [
+ r> 3drop f
+ ] [
+ r> substring
+ ] ifte ;
+
+: scan-word ( -- obj )
+ scan dup [
+ dup "use" get search dup [
+ nip
+ ] [
+ drop str>number
+ ] ifte
+ ] when ;
+
+: parsed| ( parsed parsed obj -- parsed )
+ #! Some ugly ugly code to handle [ a | b ] expressions.
+ >r unswons r> cons swap [ swons ] each swons ;
+
+: expect ( word -- )
+ dup scan = not [
+ "Expected " swap cat2 throw
+ ] [
+ drop
+ ] ifte ;
+
+: parsed ( obj -- )
+ over "|" = [ nip parsed| "]" expect ] [ swons ] ifte ;
+
+: (parse) ( str -- )
+ [
+ scan-word [
+ dup parsing? [ execute ] [ parsed ] ifte
+ ] when*
+ ] with-parser ;
+
+: parse ( str -- code )
+ #! Parse the string into a parse tree that can be executed.
+ f swap (parse) reverse ;
+
+: eval ( "X" -- X )
+ parse call ;
+
+! Used by parsing words
+: ch-search ( ch -- index )
+ "col" get "line" get rot index-of* ;
+
+: (until) ( index -- str )
+ "col" get swap dup succ "col" set "line" get substring ;
+
+: until ( ch -- str )
+ ch-search (until) ;
+
+: (until-eol) ( -- index )
+ "\n" ch-search dup -1 = [ drop "line" get str-length ] when ;
+
+: until-eol ( -- str )
+ #! This is just a hack to get "eval" to work with multiline
+ #! strings from jEdit with EOL comments. Normally, input to
+ #! the parser is already line-tokenized.
+ (until-eol) (until) ;
+
+: next-ch ( -- ch )
+ end? [ "Unexpected EOF" throw ] [ ch advance ] ifte ;
+
+: next-word-ch ( -- ch )
+ "col" get "line" get skip-blank "col" set next-ch ;
+
+IN: syntax
+
+: parsing ( -- )
+ #! Mark the most recently defined word to execute at parse
+ #! time, rather than run time. The word can use 'scan' to
+ #! read ahead in the input stream.
+ word t "parsing" set-word-property ;
+
+! Once this file has loaded, we can use 'parsing' normally.
+! This hack is needed because in Java Factor, 'parsing' is
+! not parsing, but in CFactor, it is.
+\ parsing t "parsing" set-word-property
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2003, 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: prettyprint
+USE: combinators
+USE: errors
+USE: format
+USE: kernel
+USE: logic
+USE: lists
+USE: math
+USE: namespaces
+USE: prettyprint
+USE: stack
+USE: stdio
+USE: strings
+USE: presentation
+USE: unparser
+USE: vectors
+USE: words
+
+: tab-size
+ #! Change this to suit your tastes.
+ 4 ;
+
+: prettyprint-limit ( -- limit )
+ #! Avoid infinite loops -- maximum indent, 10 levels.
+ "prettyprint-limit" get [ 40 ] unless* ;
+
+: prettyprint-indent ( indent -- )
+ #! Print the given number of spaces.
+ " " fill write ;
+
+: prettyprint-newline ( indent -- )
+ "\n" write prettyprint-indent ;
+
+: prettyprint-space ( -- )
+ " " write ;
+
+! Real definition follows
+DEFER: prettyprint*
+
+: prettyprint-element ( indent obj -- indent )
+ prettyprint* prettyprint-space ;
+
+: <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 ].
+ [
+ uncons >r prettyprint-element r>
+ dup cons? [
+ prettyprint-list
+ ] [
+ [
+ "|" write prettyprint-space prettyprint-element
+ ] when*
+ ] ifte
+ ] when* ;
+
+: prettyprint-[] ( indent list -- indent )
+ swap prettyprint-[ swap prettyprint-list prettyprint-] ;
+
+: prettyprint-{ ( indent -- indent )
+ "{" write <prettyprint ;
+
+: prettyprint-} ( indent -- indent )
+ prettyprint> "}" write ;
+
+: prettyprint-vector ( indent list -- indent )
+ #! Pretty-print a vector, without { and }.
+ [ prettyprint-element ] vector-each ;
+
+: prettyprint-{} ( indent vector -- indent )
+ dup vector-length 0 = [
+ drop "{ }" write
+ ] [
+ swap prettyprint-{ swap prettyprint-vector prettyprint-}
+ ] ifte ;
+
+: trim-newline ( str -- str )
+ dup ends-with-newline? dup [ nip ] [ drop ] ifte ;
+
+: prettyprint-comment ( comment -- )
+ trim-newline "comments" style write-attr ;
+
+: word-link ( word -- link )
+ [
+ "vocabularies'" ,
+ dup word-vocabulary ,
+ "'" ,
+ word-name ,
+ ] make-string ;
+
+: word-actions ( -- list )
+ [
+ [ "Describe" | "describe-path" ]
+ [ "Push" | "lookup" ]
+ [ "Execute" | "lookup execute" ]
+ [ "jEdit" | "lookup jedit" ]
+ [ "Usages" | "lookup usages." ]
+ ] ;
+
+: word-attrs ( word -- attrs )
+ #! Words without a vocabulary do not get a link or an action
+ #! popup.
+ dup word-vocabulary [
+ word-link [ "object-link" swons ] keep
+ word-actions <actions> "actions" swons
+ t "underline" swons
+ 3list
+ ] [
+ drop [ ]
+ ] ifte ;
+
+: prettyprint-word ( word -- )
+ dup word-name
+ swap dup word-attrs swap word-style append
+ write-attr ;
+
+: prettyprint-object ( indent obj -- indent )
+ unparse write ;
+
+: prettyprint* ( indent obj -- indent )
+ over prettyprint-limit >= [
+ unparse write
+ ] [
+ [
+ [ f = ] [ prettyprint-object ]
+ [ cons? ] [ prettyprint-[] ]
+ [ vector? ] [ prettyprint-{} ]
+ [ word? ] [ prettyprint-word ]
+ [ drop t ] [ prettyprint-object ]
+ ] cond
+ ] ifte ;
+
+: prettyprint ( obj -- )
+ 0 swap prettyprint* drop terpri ;
+
+: vocab-link ( vocab -- link )
+ "vocabularies'" swap cat2 ;
+
+: vocab-attrs ( word -- attrs )
+ vocab-link "object-link" default-style acons ;
+
+: prettyprint-vocab ( vocab -- )
+ dup vocab-attrs write-attr ;
+
+: prettyprint-IN: ( indent word -- )
+ \ IN: prettyprint-word prettyprint-space
+ word-vocabulary prettyprint-vocab prettyprint-newline ;
+
+: prettyprint-: ( indent -- indent )
+ \ : prettyprint-word prettyprint-space
+ tab-size + ;
+
+: prettyprint-; ( indent -- indent )
+ \ ; prettyprint-word
+ tab-size - ;
+
+: prettyprint-plist ( word -- )
+ dup "parsing" word-property [ " parsing" write ] when
+ "inline" word-property [ " inline" write ] when ;
+
+: . ( obj -- )
+ [
+ "prettyprint-single-line" on
+ tab-size 4 * "prettyprint-limit" set
+ prettyprint
+ ] with-scope ;
+
+: [.] ( list -- )
+ #! Unparse each element on its own line.
+ [ . ] each ;
+
+: {.} ( vector -- )
+ #! Unparse each element on its own line.
+ stack>list [ . ] each ;
+
+: .n namestack [.] ;
+: .s datastack {.} ;
+: .r callstack {.} ;
+: .c catchstack {.} ;
+
+! For integers only
+: .b >bin print ;
+: .o >oct print ;
+: .h >hex print ;
+
+: stack-effect. ( word -- )
+ stack-effect [
+ " " write
+ [ CHAR: ( , , CHAR: ) , ] make-string prettyprint-comment
+ ] when* ;
+
+: documentation. ( indent word -- indent )
+ documentation [
+ "\n" split [
+ "#!" swap cat2 prettyprint-comment
+ dup prettyprint-newline
+ ] each
+ ] when* ;
+
+: prettyprint-docs ( indent word -- indent )
+ [
+ stack-effect. dup prettyprint-newline
+ ] keep documentation. ;
+
+: see-compound ( word -- )
+ 0 swap
+ [ dupd prettyprint-IN: prettyprint-: ] keep
+ [ prettyprint-word ] keep
+ [ prettyprint-docs ] keep
+ [ word-parameter prettyprint-list prettyprint-; ] keep
+ prettyprint-plist prettyprint-newline ;
+
+: see-primitive ( word -- )
+ "PRIMITIVE: " write dup unparse write stack-effect. terpri ;
+
+: see-symbol ( word -- )
+ "SYMBOL: " write . ;
+
+: see-undefined ( word -- )
+ drop "Not defined" print ;
+
+: see ( name -- )
+ #! Show a word definition.
+ [
+ [ compound? ] [ see-compound ]
+ [ symbol? ] [ see-symbol ]
+ [ primitive? ] [ see-primitive ]
+ [ word? ] [ see-undefined ]
+ [ drop t ] [ "Not a word: " write . ]
+ ] cond ;
--- /dev/null
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: unparser
+USE: combinators
+USE: kernel
+USE: format
+USE: lists
+USE: logic
+USE: math
+USE: namespaces
+USE: parser
+USE: stack
+USE: stdio
+USE: strings
+USE: words
+
+: >digit ( n -- ch )
+ dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
+
+: integer, ( num radix -- )
+ tuck /mod >digit , dup 0 > [
+ swap integer,
+ ] [
+ 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 ;
+
+DEFER: unparse
+
+: unparse-ratio ( num -- str )
+ [
+ dup
+ numerator unparse ,
+ CHAR: / ,
+ denominator unparse ,
+ ] make-string ;
+
+: unparse-complex ( 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 digits "\\u" swap cat2 ;
+
+: unparse-ch ( ch -- ch/str )
+ dup quotable? [
+ dup ch>ascii-escape dup [
+ nip
+ ] [
+ drop ch>unicode-escape
+ ] ifte
+ ] unless ;
+
+: unparse-str ( str -- str )
+ [
+ CHAR: " , [ unparse-ch , ] str-each CHAR: " ,
+ ] make-string ;
+
+: unparse-word ( word -- str )
+ word-name dup "#<unnamed>" ? ;
+
+: fix-float ( str -- str )
+ #! This is terrible. Will go away when we do our own float
+ #! output.
+ "." over str-contains? [ ".0" cat2 ] unless ;
+
+: unparse-float ( float -- str ) (unparse-float) fix-float ;
+
+: unparse-unknown ( obj -- str )
+ [
+ "#<" ,
+ dup type type-name ,
+ " @ " ,
+ address unparse ,
+ ">" ,
+ ] make-string ;
+
+: unparse-t drop "t" ;
+: unparse-f drop "f" ;
+
+: unparse ( obj -- str )
+ {
+ >dec
+ unparse-word
+ unparse-unknown
+ unparse-unknown
+ unparse-ratio
+ unparse-complex
+ unparse-f
+ unparse-t
+ unparse-unknown
+ >dec
+ unparse-float
+ unparse-unknown
+ unparse-str
+ unparse-unknown
+ unparse-unknown
+ unparse-unknown
+ unparse-unknown
+ } generic ;
USE: stdio
USE: test
USE: threads
+USE: errors
! This only tests co-operative threads in CFactor.
! It won't give intended results in Java (or in CFactor if
[ yield 2 "x" set ] in-thread
[ 2 ] [ yield "x" get ] unit-test
[ ] [ [ flush ] in-thread flush ] unit-test
+[ ] [ [ "Errors, errors" throw ] in-thread ] unit-test
\ :get prettyprint-word
" ( var -- value ) inspects the error namestack." print
] when* ;
+
+: print-error ( quot -- )
+ #! Execute a quotation, and if it throws an error, print it
+ #! and return to the caller.
+ [ [ default-error-handler drop ] when* ] catch ;
USE: unparser
USE: vectors
+SYMBOL: cont-prompt
+SYMBOL: listener-prompt
+
+global [
+ "..." cont-prompt set
+ "ok" listener-prompt set
+] bind
+
: print-banner ( -- )
"Factor " write version print
"Copyright (C) 2003, 2004 Slava Pestov" print
"Copyright (C) 2004 Chris Double" print
"Type ``exit'' to exit, ``help'' for help." print ;
-: print-prompt ( -- )
- "ok" "prompt" style write-attr
+: prompt. ( text -- )
+ "prompt" style write-attr
! Print the space without a style, to workaround a bug in
! the GUI listener where the style from the prompt carries
! over to the input
: exit ( -- )
"quit-flag" on ;
+: (read-multiline) ( quot depth -- quot ? )
+ #! Flag indicates EOF.
+ >r read dup [
+ (parse) depth r> dup >r = [
+ ( we're done ) r> drop t
+ ] [
+ ( more input needed ) r> cont-prompt get prompt.
+ (read-multiline)
+ ] ifte
+ ] [
+ ( EOF ) r> 2drop f
+ ] ifte ;
+
+: read-multiline ( -- quot ? )
+ #! Keep parsing until the end is reached. Flag indicates
+ #! EOF.
+ f depth (read-multiline) >r reverse r> ;
+
: listener-step ( -- )
- print-prompt read [ eval-catch ] [ exit ] ifte* ;
+ listener-prompt get prompt.
+ [ read-multiline [ call ] [ exit ] ifte ] print-error ;
: listener-loop ( -- )
"quit-flag" get [
projects / factor.git / commitdiff