TUPLE: B { value T } ;
-C: <B> B
+C: <B> B ( T -- B )
;FUNCTOR
: scan-param ( -- obj ) scan-object literalize ;
-: define* ( word def effect -- ) pick set-word define-declared ;
+: define* ( word def -- ) over set-word define ;
-: define-syntax* ( word def -- ) over set-word define-syntax ;
+: define-declared* ( word def effect -- ) pick set-word define-declared ;
TUPLE: fake-quotation seq ;
: parse-definition* ( accum -- accum )
parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
-: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
+: parse-declared* ( accum -- accum )
+ "(" expect ")" parse-effect
+ [ parse-definition* ] dip
+ parsed ;
+
+: DEFINE* ( accum -- accum ) \ define-declared* parsed ;
SYNTAX: `TUPLE:
scan-param parsed
\ define-tuple-class parsed ;
SYNTAX: `M:
- effect off
scan-param parsed
scan-param parsed
\ create-method-in parsed
parse-definition*
- DEFINE* ;
+ \ define* parsed ;
SYNTAX: `C:
- effect off
scan-param parsed
scan-param parsed
- [ [ boa ] curry ] over push-all
- DEFINE* ;
+ "(" expect ")" parse-effect
+ [ [ [ boa ] curry ] over push-all ] dip parsed
+ \ define-declared* parsed ;
SYNTAX: `:
- effect off
scan-param parsed
- parse-definition*
- DEFINE* ;
+ parse-declared*
+ \ define-declared* parsed ;
SYNTAX: `SYNTAX:
- effect off
scan-param parsed
parse-definition*
- \ define-syntax* parsed ;
+ \ define-syntax parsed ;
SYNTAX: `INSTANCE:
scan-param parsed
SYNTAX: `inline [ word make-inline ] over push-all ;
-SYNTAX: `(
- ")" parse-effect effect set ;
-
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "inline" POSTPONE: `inline }
- { "(" POSTPONE: `( }
} ;
: push-functor-words ( -- )
[ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
pop-functor-words ;
-: (FUNCTOR:) ( -- word def )
+: (FUNCTOR:) ( -- word def effect )
CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
PRIVATE>
-SYNTAX: FUNCTOR: (FUNCTOR:) define ;
+SYNTAX: FUNCTOR: (FUNCTOR:) define-declared ;
-! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer macros memoize parser sequences vocabs
vocabs.loader words kernel namespaces locals.parser locals.types
SYNTAX: [wlet parse-wlet over push-all ;
-SYNTAX: :: (::) define ;
+SYNTAX: :: (::) define-declared ;
SYNTAX: M:: (M::) define ;
"|" expect "|" parse-wbindings
(parse-lambda) <wlet> ?rewrite-closures ;
-: parse-locals ( -- vars assoc )
+: parse-locals ( -- effect vars assoc )
"(" expect ")" parse-effect
- word [ over "declared-effect" set-word-prop ] when*
+ dup
in>> [ dup pair? [ first ] when ] map make-locals ;
-: parse-locals-definition ( word reader -- word quot )
+: parse-locals-definition ( word reader -- word quot effect )
[ parse-locals ] dip
((parse-lambda)) <lambda>
- [ "lambda" set-word-prop ]
- [ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
+ [ nip "lambda" set-word-prop ]
+ [ nip rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ]
+ [ drop nip ] 3tri ; inline
-: (::) ( -- word def )
+: (::) ( -- word def effect )
CREATE-WORD
[ parse-definition ]
parse-locals-definition ;
CREATE-METHOD
[
[ parse-definition ]
- parse-locals-definition
+ parse-locals-definition drop
] with-method-definition ;
\ No newline at end of file
<PRIVATE
-: real-macro-effect ( word -- effect' )
- stack-effect in>> 1 <effect> ;
+: real-macro-effect ( effect -- effect' )
+ in>> 1 <effect> ;
PRIVATE>
-: define-macro ( word definition -- )
- [ "macro" set-word-prop ]
- [ over real-macro-effect memoize-quot [ call ] append define ]
- 2bi ;
+: define-macro ( word definition effect -- )
+ real-macro-effect
+ [ drop "macro" set-word-prop ]
+ [ [ memoize-quot [ call ] append ] keep define-declared ]
+ 3bi ;
SYNTAX: MACRO: (:) define-macro ;
PRIVATE>
-: define-memoized ( word quot -- )
- [ H{ } clone ] dip
- [ pick stack-effect make-memoizer define ]
- [ nip "memo-quot" set-word-prop ]
- [ drop "memoize" set-word-prop ]
+: define-memoized ( word quot effect -- )
+ [ drop "memo-quot" set-word-prop ]
+ [ 2drop H{ } clone "memoize" set-word-prop ]
+ [ [ [ dup "memoize" word-prop ] 2dip make-memoizer ] keep define-declared ]
3tri ;
SYNTAX: MEMO: (:) define-memoized ;
SYNTAX: PEG:
(:)
- [let | def [ ] word [ ] |
+ [let | effect [ ] def [ ] word [ ] |
[
[
[let | compiled-def [ def call compile ] |
dup compiled-def compiled-parse
[ ast>> ] [ word parse-failed ] ?if
]
- word swap define
+ word swap effect define-declared
]
] with-compilation-unit
] over push-all
"!"
"\""
"#!"
- "("
"(("
":"
";"
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
-combinators arrays parser ;
+combinators arrays ;
IN: effects.parser
DEFER: parse-effect
scan [ nip ] [ = ] 2bi [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
- scan-word {
- { \ ( [ ")" parse-effect ] }
- [ ]
+ scan {
+ { "(" [ ")" parse-effect ] }
+ { f [ ")" unexpected-eof ] }
} case 2array
] when
] if
[ <effect> ] [ "Stack effect declaration must contain --" throw ] if ;
: parse-call( ( accum word -- accum )
- [ ")" parse-effect parsed ] dip parsed ;
\ No newline at end of file
+ [ ")" parse-effect ] dip 2array over push-all ;
\ No newline at end of file
sequences strings vectors words words.symbol quotations io combinators
sorting splitting math.parser effects continuations io.files vocabs
io.encodings.utf8 source-files classes hashtables compiler.errors
-compiler.units accessors sets lexer vocabs.parser slots ;
+compiler.units accessors sets lexer vocabs.parser effects.parser slots ;
IN: parser
: location ( -- loc )
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
-: (:) ( -- word def ) CREATE-WORD parse-definition ;
+: (:) ( -- word def effect )
+ CREATE-WORD
+ "(" expect ")" parse-effect
+ parse-definition swap ;
ERROR: bad-number ;
3 swap bounds-check nip first4-unsafe ; flushable
: ?nth ( n seq -- elt/f )
- 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; flushable
+ 2dup bounds-check? [ nth-unsafe ] [ 2drop f ] if ; inline
MIXIN: virtual-sequence
GENERIC: virtual-seq ( seq -- seq' )
"delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
"SYNTAX:" [
- (:) define-syntax
+ CREATE-WORD parse-definition define-syntax
] define-core-syntax
"SYMBOL:" [
] define-core-syntax
":" [
- (:) define
+ (:) define-declared
] define-core-syntax
"GENERIC:" [
scan-object forget
] define-core-syntax
- "(" [
- ")" parse-effect
- word dup [ set-stack-effect ] [ 2drop ] if
- ] define-core-syntax
-
"((" [
"))" parse-effect parsed
] define-core-syntax
-! Copyright (C) 2007, 2008 Daniel Ehrenberg, Bruno Deferrari,
+! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
dup string? [ "Vocabulary name must be a string" throw ] unless ;
: set-in ( name -- )
- check-vocab-string dup in set create-vocab (use+) ;
+ check-vocab-string dup in set create-vocab (use+) ;
\ No newline at end of file
[ recover ] 2curry ;\r
PRIVATE>\r
\r
-: define-descriptive ( word def -- )\r
- [ "descriptive-definition" set-word-prop ]\r
- [ dupd [descriptive] define ] 2bi ;\r
+: define-descriptive ( word def effect -- )\r
+ [ drop "descriptive-definition" set-word-prop ]\r
+ [ [ dupd [descriptive] ] dip define-declared ]\r
+ 3bi ;\r
\r
SYNTAX: DESCRIPTIVE: (:) define-descriptive ;\r
\r