diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index def5b02ba0..a756734f7b 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -3,7 +3,8 @@ USING: arrays alien alien.c-types alien.structs alien.arrays alien.strings kernel math namespaces parser sequences words quotations math.parser splitting grouping effects prettyprint -prettyprint.sections prettyprint.backend assocs combinators ; +prettyprint.sections prettyprint.backend assocs combinators +lexer strings.parser ; IN: alien.syntax r all-slot-names r> intersect ; + +: check-slot-shadowing ( class superclass slots -- ) + shadowed-slots [ + [ + "Definition of slot ``" % + % + "'' in class ``" % + word-name % + "'' shadows a superclass slot" % + ] "" make note. + ] with each ; + +ERROR: invalid-slot-name name ; + +M: invalid-slot-name summary + drop + "Invalid slot name" ; + +: (parse-tuple-slots) ( -- ) + #! This isn't meant to enforce any kind of policy, just + #! to check for mistakes of this form: + #! + #! TUPLE: blahblah foo bing + #! + #! : ... + scan { + { [ dup not ] [ unexpected-eof ] } + { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } + { [ dup ";" = ] [ drop ] } + [ , (parse-tuple-slots) ] + } cond ; + +: parse-tuple-slots ( -- seq ) + [ (parse-tuple-slots) ] { } make ; + +: parse-tuple-definition ( -- class superclass slots ) + CREATE-CLASS + scan { + { ";" [ tuple f ] } + { "<" [ scan-word parse-tuple-slots ] } + [ >r tuple parse-tuple-slots r> prefix ] + } case 3dup check-slot-shadowing ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 604914bd5c..c93bd11ffe 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -4,7 +4,7 @@ namespaces quotations sequences.private classes continuations generic.standard effects classes.tuple classes.tuple.private arrays vectors strings compiler.units accessors classes.algebra calendar prettyprint io.streams.string splitting inspector -columns math.order classes.private ; +columns math.order classes.private slots.private ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -94,7 +94,7 @@ TUPLE: size-test a b c d ; [ t ] [ T{ size-test } tuple-size - size-test tuple-size = + size-test tuple-layout layout-size = ] unit-test GENERIC: @@ -220,7 +220,7 @@ C: erg's-reshape-problem [ "IN: classes.tuple.tests SYMBOL: not-a-class C: not-a-class" eval -] [ error>> no-tuple-class? ] must-fail-with +] [ error>> not-a-tuple-class? ] must-fail-with ! Inheritance TUPLE: computer cpu ram ; @@ -252,7 +252,7 @@ C: laptop test-laptop-slot-values [ laptop ] [ - "laptop" get tuple-layout + "laptop" get 1 slot dup layout-echelon swap layout-superclasses nth ] unit-test @@ -490,7 +490,7 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with +[ "USE: words T{ word }" eval ] [ error>> not-a-tuple-class? ] must-fail-with ! Accessors not being forgotten... [ [ ] ] [ @@ -595,3 +595,6 @@ GENERIC: break-me ( obj -- ) [ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test + +! Insufficient type checking +[ \ vocab tuple>array drop ] must-fail diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 5ba0b7e69c..df59f34ff4 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -9,32 +9,32 @@ IN: classes.tuple M: tuple class 1 slot 2 slot { word } declare ; -ERROR: no-tuple-class class ; +ERROR: not-a-tuple object ; + +: check-tuple ( object -- tuple ) + dup tuple? [ not-a-tuple ] unless ; inline + +ERROR: not-a-tuple-class class ; + +: check-tuple-class ( class -- class ) + dup tuple-class? [ not-a-tuple-class ] unless ; inline array ( tuple -- n tuple layout ) - [ tuple-size ] [ ] [ tuple-layout ] tri ; + check-tuple [ tuple-size ] [ ] [ 1 slot ] tri ; : copy-tuple-slots ( n tuple -- array ) [ array-nth ] curry map ; PRIVATE> -: check-tuple ( class -- ) - dup tuple-class? - [ drop ] [ no-tuple-class ] if ; - : tuple>array ( tuple -- array ) prepare-tuple>array >r copy-tuple-slots r> @@ -63,7 +63,7 @@ ERROR: bad-superclass class ; r >r "cpu.x86.assembler" create dup define-symbol r> r> - >r dupd "register" set-word-prop r> - "register-size" set-word-prop ; - -: define-registers ( names size -- ) - >r dup length r> [ define-register ] curry 2each ; - -: REGISTERS: ( -- ) - scan-word ";" parse-tokens swap define-registers ; parsing - ->> - REGISTERS: 8 AL CL DL BL ; REGISTERS: 16 AX CX DX BX SP BP SI DI ; diff --git a/core/cpu/x86/assembler/syntax/syntax.factor b/core/cpu/x86/assembler/syntax/syntax.factor new file mode 100644 index 0000000000..5940663d42 --- /dev/null +++ b/core/cpu/x86/assembler/syntax/syntax.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel words sequences lexer parser ; +IN: cpu.x86.assembler.syntax + +: define-register ( name num size -- ) + >r >r "cpu.x86.assembler" create dup define-symbol r> r> + >r dupd "register" set-word-prop r> + "register-size" set-word-prop ; + +: define-registers ( names size -- ) + >r dup length r> [ define-register ] curry 2each ; + +: REGISTERS: ( -- ) + scan-word ";" parse-tokens swap define-registers ; parsing diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index cfad144737..2ac903a39b 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -209,8 +209,11 @@ M: inconsistent-next-method summary M: check-method summary drop "Invalid parameters for create-method" ; -M: no-tuple-class summary - drop "BOA constructors can only be defined for tuple classes" ; +M: not-a-tuple summary + drop "Not a tuple" ; + +M: not-a-tuple-class summary + drop "Not a tuple class" ; M: bad-superclass summary drop "Tuple classes can only inherit from other tuple classes" ; diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 099260f111..d7923ad595 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -42,14 +42,14 @@ M: integer (stack-picture) drop "object" ; GENERIC: stack-effect ( word -- effect/f ) -M: symbol stack-effect drop 0 1 ; +M: symbol stack-effect drop (( -- symbol )) ; M: word stack-effect { "declared-effect" "inferred-effect" } swap word-props [ at ] curry map [ ] find nip ; M: effect clone - [ in>> clone ] keep effect-out clone ; + [ in>> clone ] [ out>> clone ] bi ; : split-shuffle ( stack shuffle -- stack1 stack2 ) in>> length cut* ; diff --git a/core/effects/parser/parser-docs.factor b/core/effects/parser/parser-docs.factor new file mode 100644 index 0000000000..6cb39d208d --- /dev/null +++ b/core/effects/parser/parser-docs.factor @@ -0,0 +1,9 @@ +IN: effects.parser +USING: strings effects help.markup help.syntax ; + +HELP: parse-effect +{ $values { "end" string } { "effect" "an instance of " { $link effect } } } +{ $description "Parses a stack effect from the current input line." } +{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." } +$parsing-note ; + diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor new file mode 100644 index 0000000000..8f28450de7 --- /dev/null +++ b/core/effects/parser/parser.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: lexer sets sequences kernel splitting effects ; +IN: effects.parser + +: parse-effect ( end -- effect ) + parse-tokens dup { "(" "((" } intersect empty? [ + { "--" } split1 dup [ + + ] [ + "Stack effect declaration must contain --" throw + ] if + ] [ + "Stack effect declaration must not contain ( or ((" throw + ] if ; diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor new file mode 100644 index 0000000000..ba9cd5244c --- /dev/null +++ b/core/generic/parser/parser.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel words generic namespaces inspector ; +IN: generic.parser + +ERROR: not-in-a-method-error ; + +M: not-in-a-method-error summary + drop "call-next-method can only be called in a method definition" ; + +: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; + +: create-method-in ( class generic -- method ) + create-method f set-word dup save-location ; + +: CREATE-METHOD ( -- method ) + scan-word bootstrap-word scan-word create-method-in ; + +SYMBOL: current-class +SYMBOL: current-generic + +: with-method-definition ( quot -- parsed ) + [ + >r + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + r> call + ] with-scope ; inline + +: (M:) ( method def -- ) + CREATE-METHOD [ parse-definition ] with-method-definition ; + diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index f8b071e803..59fbd289db 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -228,7 +228,7 @@ M: object constructor drop f ; 1 infer->r peek-d reify-curry 1 infer-r> - 2 1 swap #call consume/produce + (( obj quot -- curry )) swap #call consume/produce ] when* ; : reify-curries ( n -- ) diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index f90dd2350c..7f5f8035fb 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,7 +1,7 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel quotations inference accessors combinators words arrays -classes ; +classes classes.tuple ; : compose-n-quot ( word -- quot' ) >quotation ; : compose-n ( quot -- ) compose-n-quot call ; @@ -46,3 +46,9 @@ C: color [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test [ fixnum instance? ] must-infer + +: bad-new-test ( -- obj ) V{ } new ; + +[ bad-new-test ] must-infer + +[ bad-new-test ] [ T{ not-a-tuple-class f V{ } } = ] must-fail-with diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 5ca10c7545..8fc72b0f09 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -2,8 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel words sequences generic math namespaces quotations assocs combinators math.bitfields inference.backend -inference.dataflow inference.state classes.tuple.private effects -inspector hashtables classes generic sets definitions ; +inference.dataflow inference.state classes.tuple +classes.tuple.private effects inspector hashtables classes +generic sets definitions ; IN: inference.transforms : pop-literals ( n -- rstate seq ) @@ -83,19 +84,26 @@ M: duplicated-slots-error summary ] 1 define-transform \ boa [ - dup +inlined+ depends-on - tuple-layout [ ] curry + dup tuple-class? [ + dup +inlined+ depends-on + tuple-layout [ ] curry + ] [ + [ not-a-tuple-class ] curry time-bomb + ] if ] 1 define-transform \ new [ 1 ensure-values peek-d value? [ - pop-literal - dup +inlined+ depends-on - tuple-layout [ ] curry - swap infer-quot + pop-literal dup tuple-class? [ + dup +inlined+ depends-on + tuple-layout [ ] curry + swap infer-quot + ] [ + \ not-a-tuple-class boa time-bomb drop + ] if ] [ - \ new 1 1 make-call-node + \ new (( class -- tuple )) make-call-node ] if ] "infer" set-word-prop diff --git a/core/inspector/inspector-tests.factor b/core/inspector/inspector-tests.factor index 72c1a9a6bf..c230364342 100644 --- a/core/inspector/inspector-tests.factor +++ b/core/inspector/inspector-tests.factor @@ -9,3 +9,29 @@ H{ } describe H{ } describe [ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test + +[ ] [ inspector-hook get-global inspector-hook set ] unit-test + +[ ] [ H{ } clone inspect ] unit-test + +[ ] [ "a" "b" &add ] unit-test + +[ H{ { "b" "a" } } ] [ me get ] unit-test + +[ ] [ "x" 0 &put ] unit-test + +[ H{ { "b" "x" } } ] [ me get ] unit-test + +[ ] [ 0 &at ] unit-test + +[ "x" ] [ me get ] unit-test + +[ ] [ &back ] unit-test + +[ ] [ "y" 0 &rename ] unit-test + +[ H{ { "y" "x" } } ] [ me get ] unit-test + +[ ] [ 0 &delete ] unit-test + +[ H{ } ] [ me get ] unit-test diff --git a/core/inspector/inspector.factor b/core/inspector/inspector.factor index fd4e11901a..d32f1c90cf 100755 --- a/core/inspector/inspector.factor +++ b/core/inspector/inspector.factor @@ -3,7 +3,7 @@ USING: arrays generic hashtables io kernel assocs math namespaces prettyprint sequences strings io.styles vectors words quotations mirrors splitting math.parser classes vocabs refs -sets ; +sets sorting ; IN: inspector GENERIC: summary ( object -- string ) @@ -78,10 +78,17 @@ SYMBOL: +editable+ : summary. ( obj -- ) [ summary ] keep write-object nl ; +: sorted-keys ( assoc -- alist ) + dup mirror? [ keys ] [ + keys + [ [ unparse-short ] keep ] { } map>assoc + sort-keys values + ] if ; + : describe* ( obj flags -- ) clone [ dup summary. - make-mirror dup keys dup empty? [ + make-mirror dup sorted-keys dup empty? [ 2drop ] [ dup enum? [ +sequence+ on ] when diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 4b129ad59d..c5bd0615a7 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -117,3 +117,8 @@ IN: kernel.tests : total-failure-2 [ ] (call) unimplemented ; [ total-failure-2 ] must-fail + +! From combinators.lib +[ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test +[ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test +[ [ sq ] tri@ ] must-infer diff --git a/core/lexer/lexer-docs.factor b/core/lexer/lexer-docs.factor new file mode 100644 index 0000000000..a7dcb161e5 --- /dev/null +++ b/core/lexer/lexer-docs.factor @@ -0,0 +1,109 @@ +IN: lexer +USING: help.markup help.syntax kernel math sequences strings +words quotations ; + +HELP: lexer +{ $var-description "Stores the current " { $link lexer } " instance." } +{ $class-description "An object for tokenizing parser input. It has the following slots:" + { $list + { { $snippet "text" } " - the lines being parsed; an array of strings" } + { { $snippet "line" } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" } + { { $snippet "column" } " - the current column position, zero-based" } + } +"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ; + +HELP: +{ $values { "text" "a sequence of strings" } { "lexer" lexer } } +{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ; + +HELP: next-line +{ $values { "lexer" lexer } } +{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ; + +HELP: lexer-error +{ $error-description "Thrown when the lexer encounters invalid input. A lexer error wraps an underlying error together with line and column numbers." } ; + +HELP: +{ $values { "msg" "an error" } { "error" lexer-error } } +{ $description "Creates a new " { $link lexer-error } ", filling in the location information from the current " { $link lexer } "." } ; + +HELP: skip +{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } +{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; + +HELP: change-lexer-column +{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } +{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; + +HELP: skip-blank +{ $values { "lexer" lexer } } +{ $contract "Skips whitespace characters." } +{ $notes "Custom lexers can implement this generic word." } ; + +HELP: skip-word +{ $values { "lexer" lexer } } +{ $contract + "Skips until the end of the current token." + $nl + "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line." +} +{ $notes "Custom lexers can implement this generic word." } ; + +HELP: still-parsing-line? +{ $values { "lexer" lexer } { "?" "a boolean" } } +{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; + +HELP: parse-token +{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } +{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; + +HELP: scan +{ $values { "str/f" "a " { $link string } " or " { $link f } } } +{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } +$parsing-note ; + +HELP: still-parsing? +{ $values { "lexer" lexer } { "?" "a boolean" } } +{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; + +HELP: parse-tokens +{ $values { "end" string } { "seq" "a new sequence of strings" } } +{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } +{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } +$parsing-note ; + +HELP: unexpected +{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } +{ $description "Throws an " { $link unexpected } " error." } +{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } +{ $examples + "Parsing the following snippet will throw this error:" + { $code "[ 1 2 3 }" } +} ; + +HELP: unexpected-eof +{ $values { "word" "a " { $link word } } } +{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ; + +HELP: with-lexer +{ $values { "lexer" lexer } { "quot" quotation } } +{ $description "Calls the quotation with the " { $link lexer } " variable set to the given lexer. The quotation can make use of words such as " { $link scan } ". Any errors thrown by the quotation are wrapped in " { $link lexer-error } " instances." } ; + +HELP: lexer-factory +{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ; + + +ARTICLE: "parser-lexer" "The lexer" +"A variable that encapsulate internal parser state:" +{ $subsection lexer } +"Creating a default lexer:" +{ $subsection } +"A word to test of the end of input has been reached:" +{ $subsection still-parsing? } +"A word to advance the lexer to the next line:" +{ $subsection next-line } +"Two generic words to override the lexer's token boundary detection:" +{ $subsection skip-blank } +{ $subsection skip-word } +"Utility combinator:" +{ $subsection with-lexer } ; diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor new file mode 100644 index 0000000000..3d65fb95ca --- /dev/null +++ b/core/lexer/lexer.factor @@ -0,0 +1,133 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences accessors namespaces math words strings +debugger io vectors arrays math.parser combinators inspector +continuations ; +IN: lexer + +TUPLE: lexer text line line-text line-length column ; + +: next-line ( lexer -- ) + dup [ line>> ] [ text>> ] bi ?nth >>line-text + dup line-text>> length >>line-length + [ 1+ ] change-line + 0 >>column + drop ; + +: new-lexer ( text class -- lexer ) + new + 0 >>line + swap >>text + dup next-line ; inline + +: ( text -- lexer ) + lexer new-lexer ; + +: skip ( i seq ? -- n ) + over >r + [ swap CHAR: \s eq? xor ] curry find-from drop + [ r> drop ] [ r> length ] if* ; + +: change-lexer-column ( lexer quot -- ) + swap + [ dup lexer-column swap lexer-line-text rot call ] keep + set-lexer-column ; inline + +GENERIC: skip-blank ( lexer -- ) + +M: lexer skip-blank ( lexer -- ) + [ t skip ] change-lexer-column ; + +GENERIC: skip-word ( lexer -- ) + +M: lexer skip-word ( lexer -- ) + [ + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if + ] change-lexer-column ; + +: still-parsing? ( lexer -- ? ) + dup lexer-line swap lexer-text length <= ; + +: still-parsing-line? ( lexer -- ? ) + dup lexer-column swap lexer-line-length < ; + +: (parse-token) ( lexer -- str ) + [ lexer-column ] keep + [ skip-word ] keep + [ lexer-column ] keep + lexer-line-text subseq ; + +: parse-token ( lexer -- str/f ) + dup still-parsing? [ + dup skip-blank + dup still-parsing-line? + [ (parse-token) ] [ dup next-line parse-token ] if + ] [ drop f ] if ; + +: scan ( -- str/f ) lexer get parse-token ; + +ERROR: unexpected want got ; + +GENERIC: expected>string ( obj -- str ) + +M: f expected>string drop "end of input" ; +M: word expected>string word-name ; +M: string expected>string ; + +M: unexpected error. + "Expected " write + dup unexpected-want expected>string write + " but got " write + unexpected-got expected>string print ; + +PREDICATE: unexpected-eof < unexpected + unexpected-got not ; + +: unexpected-eof ( word -- * ) f unexpected ; + +: (parse-tokens) ( accum end -- accum ) + scan 2dup = [ + 2drop + ] [ + [ pick push (parse-tokens) ] [ unexpected-eof ] if* + ] if ; + +: parse-tokens ( end -- seq ) + 100 swap (parse-tokens) >array ; + +TUPLE: lexer-error line column line-text error ; + +: ( msg -- error ) + \ lexer-error new + lexer get + [ line>> >>line ] + [ column>> >>column ] + [ line-text>> >>line-text ] + tri + swap >>error ; + +: lexer-dump ( error -- ) + [ line>> number>string ": " append ] + [ line-text>> dup string? [ drop "" ] unless ] + [ column>> 0 or ] tri + pick length + CHAR: \s + [ write ] [ print ] [ write "^" print ] tri* ; + +M: lexer-error error. + [ lexer-dump ] [ error>> error. ] bi ; + +M: lexer-error summary + error>> summary ; + +M: lexer-error compute-restarts + error>> compute-restarts ; + +M: lexer-error error-help + error>> error-help ; + +: with-lexer ( lexer quot -- newquot ) + [ lexer set ] dip [ rethrow ] recover ; inline + +SYMBOL: lexer-factory + +[ ] lexer-factory set-global diff --git a/core/listener/listener.factor b/core/listener/listener.factor index e00e64f4bc..4e2a8c768e 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io kernel math math.parser memory -namespaces parser sequences strings io.styles +namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger definitions compiler.units accessors ; IN: listener @@ -51,7 +51,7 @@ SYMBOL: error-hook listener-hook get call prompt. [ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ] [ - dup parse-error? [ + dup lexer-error? [ error-hook get call ] [ rethrow diff --git a/core/mirrors/mirrors.factor b/core/mirrors/mirrors.factor index 0a49163075..607ba1542f 100755 --- a/core/mirrors/mirrors.factor +++ b/core/mirrors/mirrors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs hashtables kernel sequences generic words arrays classes slots slots.private classes.tuple math vectors -quotations sorting prettyprint accessors ; +quotations accessors ; IN: mirrors : all-slots ( class -- slots ) @@ -47,13 +47,8 @@ M: mirror assoc-size mirror-slots length ; INSTANCE: mirror assoc -: sort-assoc ( assoc -- alist ) - >alist - [ [ first unparse-short ] keep ] { } map>assoc - sort-keys values ; - GENERIC: make-mirror ( obj -- assoc ) -M: hashtable make-mirror sort-assoc ; +M: hashtable make-mirror ; M: integer make-mirror drop f ; M: array make-mirror ; M: vector make-mirror ; diff --git a/core/optimizer/math/partial/partial.factor b/core/optimizer/math/partial/partial.factor index 8b5e25deb1..30a726e022 100644 --- a/core/optimizer/math/partial/partial.factor +++ b/core/optimizer/math/partial/partial.factor @@ -59,7 +59,7 @@ PREDICATE: math-partial < word : define-integer-op-word ( word fix-word big-word -- ) [ [ integer-op-word ] [ integer-op-quot ] 3bi - 2 1 define-declared + (( x y -- z )) define-declared ] [ [ integer-op-word ] [ 2drop ] 3bi diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 2ec9f2de54..1aecfbd60d 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -1,7 +1,7 @@ USING: help.markup help.syntax kernel sequences words math strings vectors quotations generic effects classes vocabs.loader definitions io vocabs source-files -quotations namespaces compiler.units assocs ; +quotations namespaces compiler.units assocs lexer ; IN: parser ARTICLE: "vocabulary-search-shadow" "Shadowing word names" @@ -135,25 +135,6 @@ $nl { $subsection "defining-words" } { $subsection "parsing-tokens" } ; -ARTICLE: "parser-lexer" "The lexer" -"Two variables that encapsulate internal parser state:" -{ $subsection file } -{ $subsection lexer } -"Creating a default lexer:" -{ $subsection } -"A word to test of the end of input has been reached:" -{ $subsection still-parsing? } -"A word to advance the lexer to the next line:" -{ $subsection next-line } -"Two generic words to override the lexer's token boundary detection:" -{ $subsection skip-blank } -{ $subsection skip-word } -"A utility used when parsing string literals:" -{ $subsection parse-string } -"The parser can be invoked with a custom lexer:" -{ $subsection (parse-lines) } -{ $subsection with-parser } ; - ARTICLE: "parser-files" "Parsing source files" "The parser can run source files:" { $subsection run-file } @@ -192,25 +173,6 @@ $nl ABOUT: "parser" -: $parsing-note ( children -- ) - drop - "This word should only be called from parsing words." - $notes ; - -HELP: lexer -{ $var-description "Stores the current " { $link lexer } " instance." } -{ $class-description "An object for tokenizing parser input. It has the following slots:" - { $list - { { $link lexer-text } " - the lines being parsed; an array of strings" } - { { $link lexer-line } " - the line number being parsed; unlike most indices this is 1-based for friendlier error reporting and integration with text editors" } - { { $link lexer-column } " - the current column position, zero-based" } - } -"Custom lexing can be implemented by delegating a tuple to an instance of this class and implementing the " { $link skip-word } " and " { $link skip-blank } " generic words." } ; - -HELP: -{ $values { "text" "a sequence of strings" } { "lexer" lexer } } -{ $description "Creates a new lexer for tokenizing the given sequence of lines." } ; - HELP: location { $values { "loc" "a " { $snippet "{ path line# }" } " pair" } } { $description "Outputs the current parser location. This value can be passed to " { $link set-where } " or " { $link remember-definition } "." } ; @@ -226,73 +188,9 @@ HELP: parser-notes? { $values { "?" "a boolean" } } { $description "Tests if the parser will print various notes and warnings. To disable parser notes, either set " { $link parser-notes } " to " { $link f } ", or pass the " { $snippet "-quiet" } " command line switch." } ; -HELP: next-line -{ $values { "lexer" lexer } } -{ $description "Advances the lexer to the next input line, discarding the remainder of the current line." } ; - -HELP: parse-error -{ $error-description "Thrown when the parser encounters invalid input. A parse error wraps an underlying error and holds the file being parsed, line number, and column number." } ; - -HELP: -{ $values { "msg" "an error" } { "error" parse-error } } -{ $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; - -HELP: skip -{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } } -{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ; - -HELP: change-lexer-column -{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } } -{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ; - -HELP: skip-blank -{ $values { "lexer" lexer } } -{ $contract "Skips whitespace characters." } -{ $notes "Custom lexers can implement this generic word." } ; - -HELP: skip-word -{ $values { "lexer" lexer } } -{ $contract - "Skips until the end of the current token." - $nl - "The default implementation treats a single " { $snippet "\"" } " as a word by itself; otherwise it searches forward until a whitespace character or the end of the line." -} -{ $notes "Custom lexers can implement this generic word." } ; - -HELP: still-parsing-line? -{ $values { "lexer" lexer } { "?" "a boolean" } } -{ $description "Outputs " { $link f } " if the end of the current line has been reached, " { $link t } " otherwise." } ; - -HELP: parse-token -{ $values { "lexer" lexer } { "str/f" "a " { $link string } " or " { $link f } } } -{ $description "Reads the next token from the lexer. Tokens are delimited by whitespace, with the exception that " { $snippet "\"" } " is treated like a single token even when not followed by whitespace." } ; - -HELP: scan -{ $values { "str/f" "a " { $link string } " or " { $link f } } } -{ $description "Reads the next token from the lexer. See " { $link parse-token } " for details." } -$parsing-note ; - -HELP: bad-escape -{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ; - HELP: bad-number { $error-description "Indicates the parser encountered an invalid numeric literal." } ; -HELP: escape -{ $values { "escape" "a single-character escape" } { "ch" "a character" } } -{ $description "Converts from a single-character escape code and the corresponding character." } -{ $examples { $example "USING: kernel parser prettyprint ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; - -HELP: parse-string -{ $values { "str" "a new " { $link string } } } -{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } -{ $errors "Throws an error if the string contains an invalid escape sequence." } -$parsing-note ; - -HELP: still-parsing? -{ $values { "lexer" lexer } { "?" "a boolean" } } -{ $description "Outputs " { $link f } " if end of input has been reached, " { $link t } " otherwise." } ; - HELP: use { $var-description "A variable holding the current vocabulary search path as a sequence of assocs." } ; @@ -338,12 +236,6 @@ HELP: create-in { $description "Creates a word in the current vocabulary. Until re-defined, the word throws an error when invoked." } $parsing-note ; -HELP: parse-tokens -{ $values { "end" string } { "seq" "a new sequence of strings" } } -{ $description "Reads a sequence of tokens until the first occurrence of " { $snippet "end" } ". The tokens remain as strings and are not processed in any way." } -{ $examples "This word is used to implement " { $link POSTPONE: USING: } "." } -$parsing-note ; - HELP: CREATE { $values { "word" word } } { $description "Reads the next token from the line currently being parsed, and creates a word with that name in the current vocabulary." } @@ -369,31 +261,6 @@ HELP: scan-word { $errors "Throws an error if the token does not name a word, and does not parse as a number." } $parsing-note ; -HELP: invalid-slot-name -{ $values { "name" string } } -{ $description "Throws an " { $link invalid-slot-name } " error." } -{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." } -{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:" - { $code - "TUPLE: my-mistaken-tuple slot-a slot-b" - "" - ": some-word ( a b c -- ) ... ;" - } -} ; - -HELP: unexpected -{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } } -{ $description "Throws an " { $link unexpected } " error." } -{ $error-description "Thrown by the parser if an unmatched closing delimiter is encountered." } -{ $examples - "Parsing the following snippet will throw this error:" - { $code "[ 1 2 3 }" } -} ; - -HELP: unexpected-eof -{ $values { "word" "a " { $link word } } } -{ $description "Throws an " { $link unexpected } " error indicating the parser was looking for an occurrence of " { $snippet "word" } " but encountered end of file." } ; - HELP: parse-step { $values { "accum" vector } { "end" word } { "?" "a boolean" } } { $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." } @@ -417,28 +284,15 @@ HELP: parsed { $description "Convenience word for parsing words. It behaves exactly the same as " { $link push } ", except the accumulator remains on the stack." } $parsing-note ; -HELP: with-parser -{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( -- accum )" } } { "newquot" "a new " { $link quotation } } } -{ $description "Sets up the parser and calls the quotation. The quotation can make use of parsing words such as " { $link scan } " and " { $link parse-until } ". It must yield a sequence, which is converted to a quotation and output. Any errors thrown by the quotation are wrapped in parse errors." } ; - HELP: (parse-lines) { $values { "lexer" lexer } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code using a custom lexer. The vocabulary search path is taken from the current scope." } -{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ; +{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-lines { $values { "lines" "a sequence of strings" } { "quot" "a new " { $link quotation } } } { $description "Parses Factor source code which has been tokenized into lines. The vocabulary search path is taken from the current scope." } -{ $errors "Throws a " { $link parse-error } " if the input is malformed." } ; - -HELP: lexer-factory -{ $var-description "A variable holding a quotation with stack effect " { $snippet "( lines -- lexer )" } ". This quotation is called by the parser to create " { $link lexer } " instances. This variable can be rebound to a quotation which outputs a custom tuple delegating to " { $link lexer } " to customize syntax." } ; - -HELP: parse-effect -{ $values { "end" string } { "effect" "an instance of " { $link effect } } } -{ $description "Parses a stack effect from the current input line." } -{ $examples "This word is used by " { $link POSTPONE: ( } " and " { $link POSTPONE: (( } " to parse stack effect declarations." } -$parsing-note ; +{ $errors "Throws a " { $link lexer-error } " if the input is malformed." } ; HELP: parse-base { $values { "base" "an integer between 2 and 36" } { "parsed" integer } } diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 555c6eb32c..074b3738ac 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -198,7 +198,7 @@ IN: parser.tests [ "IN: parser.tests : x ; : y 3 throw ; this is an error" "a" parse-stream - ] [ parse-error? ] must-fail-with + ] [ source-file-error? ] must-fail-with [ t ] [ "y" "parser.tests" lookup >boolean @@ -298,12 +298,12 @@ IN: parser.tests [ "IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?" "removing-the-predicate" parse-stream - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ "IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;" "redefining-a-class-1" parse-stream - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test" @@ -313,7 +313,7 @@ IN: parser.tests [ "IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" "redefining-a-class-3" parse-stream drop - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ;" @@ -323,7 +323,7 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ error>> error>> no-word-error? ] must-fail-with + ] [ error>> error>> error>> no-word-error? ] must-fail-with [ ] [ "IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" @@ -333,12 +333,12 @@ IN: parser.tests [ "IN: parser.tests \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] [ error>> error>> no-word-error? ] must-fail-with + ] [ error>> error>> error>> no-word-error? ] must-fail-with [ "IN: parser.tests : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop - ] [ error>> error>> redefine-error? ] must-fail-with + ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval @@ -485,3 +485,9 @@ must-fail-with [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ "DEFER: blah" eval ] [ error>> no-current-vocab? ] must-fail-with + +[ + "IN: parser.tests : blah ; parsing FORGET: blah" eval +] [ + error>> staging-violation? +] must-fail-with diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 129d5ef2ee..601245c463 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -4,38 +4,17 @@ USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string vocabs -io.encodings.utf8 source-files classes classes.tuple hashtables -compiler.errors compiler.units accessors sets ; +io.encodings.utf8 source-files classes hashtables +compiler.errors compiler.units accessors sets lexer ; IN: parser -TUPLE: lexer text line line-text line-length column ; - -: next-line ( lexer -- ) - dup [ line>> ] [ text>> ] bi ?nth >>line-text - dup line-text>> length >>line-length - [ 1+ ] change-line - 0 >>column - drop ; - -: new-lexer ( text class -- lexer ) - new - 0 >>line - swap >>text - dup next-line ; inline - -: ( text -- lexer ) - lexer new-lexer ; - : location ( -- loc ) - file get lexer get lexer-line 2dup and - [ >r source-file-path r> 2array ] [ 2drop f ] if ; + file get lexer get line>> 2dup and + [ >r path>> r> 2array ] [ 2drop f ] if ; : save-location ( definition -- ) location remember-definition ; -: save-class-location ( class -- ) - location remember-class ; - SYMBOL: parser-notes t parser-notes set-global @@ -43,161 +22,16 @@ t parser-notes set-global : parser-notes? ( -- ? ) parser-notes get "quiet" get not and ; -: file. ( file -- ) - [ - source-file-path pprint - ] [ - "" write - ] if* ":" write ; - : note. ( str -- ) parser-notes? [ - file get file. - lexer get [ - lexer-line number>string print - ] [ - nl - ] if* + file get [ file. ] when* + lexer get line>> number>string write ": " write "Note: " write dup print ] when drop ; -: skip ( i seq ? -- n ) - over >r - [ swap CHAR: \s eq? xor ] curry find-from drop - [ r> drop ] [ r> length ] if* ; - -: change-lexer-column ( lexer quot -- ) - swap - [ dup lexer-column swap lexer-line-text rot call ] keep - set-lexer-column ; inline - -GENERIC: skip-blank ( lexer -- ) - -M: lexer skip-blank ( lexer -- ) - [ t skip ] change-lexer-column ; - -GENERIC: skip-word ( lexer -- ) - -M: lexer skip-word ( lexer -- ) - [ - 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if - ] change-lexer-column ; - -: still-parsing? ( lexer -- ? ) - dup lexer-line swap lexer-text length <= ; - -: still-parsing-line? ( lexer -- ? ) - dup lexer-column swap lexer-line-length < ; - -: (parse-token) ( lexer -- str ) - [ lexer-column ] keep - [ skip-word ] keep - [ lexer-column ] keep - lexer-line-text subseq ; - -: parse-token ( lexer -- str/f ) - dup still-parsing? [ - dup skip-blank - dup still-parsing-line? - [ (parse-token) ] [ dup next-line parse-token ] if - ] [ drop f ] if ; - -: scan ( -- str/f ) lexer get parse-token ; - -ERROR: bad-escape ; - -M: bad-escape summary drop "Bad escape code" ; - -: escape ( escape -- ch ) - H{ - { CHAR: a CHAR: \a } - { 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: \" } - } at [ bad-escape ] unless* ; - -SYMBOL: name>char-hook - -name>char-hook global [ - [ "Unicode support not available" throw ] or -] change-at - -: unicode-escape ( str -- ch str' ) - "{" ?head-slice [ - CHAR: } over index cut-slice - >r >string name>char-hook get call r> - rest-slice - ] [ - 6 cut-slice >r hex> r> - ] if ; - -: next-escape ( str -- ch str' ) - "u" ?head-slice [ - unicode-escape - ] [ - unclip-slice escape swap - ] if ; - -: (parse-string) ( str -- m ) - dup [ "\"\\" member? ] find dup [ - >r cut-slice >r % r> rest-slice r> - dup CHAR: " = [ - drop slice-from - ] [ - drop next-escape >r , r> (parse-string) - ] if - ] [ - "Unterminated string" throw - ] if ; - -: parse-string ( -- str ) - lexer get [ - [ swap tail-slice (parse-string) ] "" make swap - ] change-lexer-column ; - -TUPLE: parse-error file line column line-text error ; - -: ( msg -- error ) - \ parse-error new - file get >>file - lexer get line>> >>line - lexer get column>> >>column - lexer get line-text>> >>line-text - swap >>error ; - -: parse-dump ( error -- ) - { - [ file>> file. ] - [ line>> number>string print ] - [ line-text>> dup string? [ print ] [ drop ] if ] - [ column>> 0 or CHAR: \s write ] - } cleave - "^" print ; - -M: parse-error error. - [ parse-dump ] [ error>> error. ] bi ; - -M: parse-error summary - error>> summary ; - -M: parse-error compute-restarts - error>> compute-restarts ; - -M: parse-error error-help - error>> error-help ; - SYMBOL: use SYMBOL: in -: word/vocab% ( word -- ) - "(" % dup word-vocabulary % " " % word-name % ")" % ; - : (use+) ( vocab -- ) vocab-words use get push ; @@ -216,25 +50,8 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -ERROR: unexpected want got ; - -PREDICATE: unexpected-eof < unexpected - unexpected-got not ; - M: parsing-word stack-effect drop (( parsed -- parsed )) ; -: unexpected-eof ( word -- * ) f unexpected ; - -: (parse-tokens) ( accum end -- accum ) - scan 2dup = [ - 2drop - ] [ - [ pick push (parse-tokens) ] [ unexpected-eof ] if* - ] if ; - -: parse-tokens ( end -- seq ) - 100 swap (parse-tokens) >array ; - ERROR: no-current-vocab ; M: no-current-vocab summary ( obj -- ) @@ -248,18 +65,8 @@ M: no-current-vocab summary ( obj -- ) : CREATE ( -- word ) scan create-in ; -: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; - : CREATE-WORD ( -- word ) CREATE dup reset-generic ; -: create-class-in ( word -- word ) - current-vocab create - dup save-class-location - dup predicate-word dup set-word save-location ; - -: CREATE-CLASS ( -- word ) - scan create-class-in ; - : word-restarts ( possibilities -- restarts ) natural-sort [ [ "Use the word " swap summary append ] keep @@ -296,62 +103,6 @@ M: no-word-error summary ] ?if ] when ; -: create-method-in ( class generic -- method ) - create-method f set-word dup save-location ; - -: CREATE-METHOD ( -- method ) - scan-word bootstrap-word scan-word create-method-in ; - -: shadowed-slots ( superclass slots -- shadowed ) - >r all-slot-names r> intersect ; - -: check-slot-shadowing ( class superclass slots -- ) - shadowed-slots [ - [ - "Definition of slot ``" % - % - "'' in class ``" % - word-name % - "'' shadows a superclass slot" % - ] "" make note. - ] with each ; - -ERROR: invalid-slot-name name ; - -M: invalid-slot-name summary - drop - "Invalid slot name" ; - -: (parse-tuple-slots) ( -- ) - #! This isn't meant to enforce any kind of policy, just - #! to check for mistakes of this form: - #! - #! TUPLE: blahblah foo bing - #! - #! : ... - scan { - { [ dup not ] [ unexpected-eof ] } - { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] } - { [ dup ";" = ] [ drop ] } - [ , (parse-tuple-slots) ] - } cond ; - -: parse-tuple-slots ( -- seq ) - [ (parse-tuple-slots) ] { } make ; - -: parse-tuple-definition ( -- class superclass slots ) - CREATE-CLASS - scan { - { ";" [ tuple f ] } - { "<" [ scan-word parse-tuple-slots ] } - [ >r tuple parse-tuple-slots r> prefix ] - } case 3dup check-slot-shadowing ; - -ERROR: not-in-a-method-error ; - -M: not-in-a-method-error summary - drop "call-next-method can only be called in a method definition" ; - ERROR: staging-violation word ; M: staging-violation summary @@ -362,6 +113,10 @@ M: staging-violation summary dup changed-definitions get key? [ staging-violation ] when execute ; +: scan-object ( -- object ) + scan-word dup parsing-word? + [ V{ } clone swap execute-parsing first ] when ; + : parse-step ( accum end -- accum ? ) scan-word { { [ 2dup eq? ] [ 2drop f ] } @@ -379,37 +134,12 @@ M: staging-violation summary : parsed ( accum obj -- accum ) over push ; -: with-parser ( lexer quot -- newquot ) - swap lexer set - [ call >quotation ] [ rethrow ] recover ; - : (parse-lines) ( lexer -- quot ) - [ f parse-until ] with-parser ; - -SYMBOL: lexer-factory - -[ ] lexer-factory set-global + [ f parse-until >quotation ] with-lexer ; : parse-lines ( lines -- quot ) lexer-factory get call (parse-lines) ; -! Parsing word utilities -: parse-effect ( end -- effect ) - parse-tokens dup { "(" "((" } intersect empty? [ - { "--" } split1 dup [ - - ] [ - "Stack effect declaration must contain --" throw - ] if - ] [ - "Stack effect declaration must not contain ( or ((" throw - ] if ; - -ERROR: bad-number ; - -: parse-base ( parsed base -- parsed ) - scan swap base> [ bad-number ] unless* parsed ; - : parse-literal ( accum end quot -- accum ) >r parse-until r> call parsed ; inline @@ -418,40 +148,14 @@ ERROR: bad-number ; : (:) ( -- word def ) CREATE-WORD parse-definition ; -SYMBOL: current-class -SYMBOL: current-generic - -: with-method-definition ( quot -- parsed ) - [ - >r - [ "method-class" word-prop current-class set ] - [ "method-generic" word-prop current-generic set ] - [ ] tri - r> call - ] with-scope ; inline - -: (M:) ( method def -- ) - CREATE-METHOD [ parse-definition ] with-method-definition ; - -: scan-object ( -- object ) - scan-word dup parsing-word? - [ V{ } clone swap execute first ] when ; - -GENERIC: expected>string ( obj -- str ) - -M: f expected>string drop "end of input" ; -M: word expected>string word-name ; -M: string expected>string ; - -M: unexpected error. - "Expected " write - dup unexpected-want expected>string write - " but got " write - unexpected-got expected>string print ; +ERROR: bad-number ; M: bad-number summary drop "Bad number literal" ; +: parse-base ( parsed base -- parsed ) + scan swap base> [ bad-number ] unless* parsed ; + SYMBOL: bootstrap-syntax : with-file-vocabs ( quot -- ) diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index d5f4dd5906..9e11611f5b 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -167,9 +167,11 @@ unit-test "another-retain-layout" another-retain-layout-test check-see ] unit-test +DEFER: parse-error-file + : another-soft-break-test { - "USING: namespaces parser sequences ;" + "USING: namespaces sequences ;" "IN: prettyprint.tests" ": another-soft-break-layout ( node -- quot )" " parse-error-file" @@ -183,7 +185,7 @@ unit-test : string-layout { - "USING: io kernel parser ;" + "USING: io kernel lexer ;" "IN: prettyprint.tests" ": string-layout-test ( error -- )" " \"Expected \" write dup unexpected-want expected>string write" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 02a7191f0a..2d05d3c2ef 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -206,6 +206,8 @@ M: slice virtual@ [ slice-from + ] [ slice-seq ] bi ; M: slice length dup slice-to swap slice-from - ; +: short ( seq n -- seq n' ) over length min ; inline + : head-slice ( seq n -- slice ) (head) ; : tail-slice ( seq n -- slice ) (tail) ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 454f148974..2c5c19708e 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -75,11 +75,35 @@ M: pathname forget* SYMBOL: file +TUPLE: source-file-error file error ; + +: ( msg -- error ) + \ source-file-error new + file get >>file + swap >>error ; + +: file. ( file -- ) path>> . ; + +M: source-file-error error. + [ file>> file. ] [ error>> error. ] bi ; + +M: source-file-error summary + error>> summary ; + +M: source-file-error compute-restarts + error>> compute-restarts ; + +M: source-file-error error-help + error>> error-help ; + : with-source-file ( name quot -- ) #! Should be called from inside with-compilation-unit. [ swap source-file dup file set source-file-definitions old-definitions set - [ ] [ file get rollback-source-file ] cleanup + [ + file get rollback-source-file + rethrow + ] recover ] with-scope ; inline diff --git a/core/strings/parser/parser-docs.factor b/core/strings/parser/parser-docs.factor new file mode 100644 index 0000000000..e1c53cd87a --- /dev/null +++ b/core/strings/parser/parser-docs.factor @@ -0,0 +1,16 @@ +USING: help.markup help.syntax strings lexer ; +IN: strings.parser + +HELP: bad-escape +{ $error-description "Indicates the parser encountered an invalid escape code following a backslash (" { $snippet "\\" } ") in a string literal. See " { $link "escape" } " for a list of valid escape codes." } ; + +HELP: escape +{ $values { "escape" "a single-character escape" } { "ch" "a character" } } +{ $description "Converts from a single-character escape code and the corresponding character." } +{ $examples { $example "USING: kernel prettyprint strings.parser ;" "CHAR: n escape CHAR: \\n = ." "t" } } ; + +HELP: parse-string +{ $values { "str" "a new " { $link string } } } +{ $description "Parses the line until a quote (\"), interpreting escape codes along the way." } +{ $errors "Throws an error if the string contains an invalid escape sequence." } +$parsing-note ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor new file mode 100644 index 0000000000..08421b4a20 --- /dev/null +++ b/core/strings/parser/parser.factor @@ -0,0 +1,62 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel inspector assocs namespaces splitting sequences +strings math.parser lexer ; +IN: strings.parser + +ERROR: bad-escape ; + +M: bad-escape summary drop "Bad escape code" ; + +: escape ( escape -- ch ) + H{ + { CHAR: a CHAR: \a } + { 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: \" } + } at [ bad-escape ] unless* ; + +SYMBOL: name>char-hook + +name>char-hook global [ + [ "Unicode support not available" throw ] or +] change-at + +: unicode-escape ( str -- ch str' ) + "{" ?head-slice [ + CHAR: } over index cut-slice + >r >string name>char-hook get call r> + rest-slice + ] [ + 6 cut-slice >r hex> r> + ] if ; + +: next-escape ( str -- ch str' ) + "u" ?head-slice [ + unicode-escape + ] [ + unclip-slice escape swap + ] if ; + +: (parse-string) ( str -- m ) + dup [ "\"\\" member? ] find dup [ + >r cut-slice >r % r> rest-slice r> + dup CHAR: " = [ + drop slice-from + ] [ + drop next-escape >r , r> (parse-string) + ] if + ] [ + "Unterminated string" throw + ] if ; + +: parse-string ( -- str ) + lexer get [ + [ swap tail-slice (parse-string) ] "" make swap + ] change-lexer-column ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 91a453408d..4d4b81d00e 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays bit-arrays byte-arrays byte-vectors -definitions generic hashtables kernel math -namespaces parser sequences strings sbufs vectors words -quotations io assocs splitting classes.tuple generic.standard -generic.math classes io.files vocabs float-arrays -classes.union classes.intersection classes.mixin -classes.predicate classes.singleton compiler.units -combinators debugger ; +definitions generic hashtables kernel math namespaces parser +lexer sequences strings strings.parser sbufs vectors +words quotations io assocs splitting classes.tuple +generic.standard generic.math generic.parser classes io.files +vocabs float-arrays classes.parser classes.union +classes.intersection classes.mixin classes.predicate +classes.singleton classes.tuple.parser compiler.units +combinators debugger effects.parser ; IN: bootstrap.syntax ! These words are defined as a top-level form, instead of with @@ -167,7 +168,7 @@ IN: bootstrap.syntax "C:" [ CREATE-WORD - scan-word dup check-tuple + scan-word check-tuple-class [ boa ] curry define-inline ] define-syntax diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 45b0d6b019..5ed0b0a34c 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -68,7 +68,7 @@ IN: vocabs.loader.tests "resource:core/vocabs/loader/test/a/a.factor" parse-stream -] [ error>> error>> no-word-error? ] must-fail-with +] [ error>> error>> error>> no-word-error? ] must-fail-with 0 "count-me" set-global diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor index 7d3ef89759..c83d4b5152 100644 --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -1,4 +1,4 @@ -USING: parser kernel math sequences namespaces assocs inspector +USING: parser lexer kernel math sequences namespaces assocs inspector words splitting math.parser arrays sequences.next mirrors shuffle compiler.units ; IN: bitfields diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index 4151b44cfb..e6c97b90dd 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces +USING: combinators.short-circuit kernel namespaces math math.constants math.functions diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index a1feac381d..e3c54e0744 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces +USING: combinators.short-circuit kernel namespaces math math.functions math.vectors @@ -104,11 +104,11 @@ VARS: population-label cohesion-label alignment-label separation-label ; C[ [ run ] in-thread ] slate> set-slate-graft C[ loop off ] slate> set-slate-ungraft - ""