M: real-type (fortran-ret-type>c-type)
drop real-functions-return-double? [ "double" ] [ "float" ] if ;
- : suffix! ( seq elt -- seq ) over push ; inline
- : append! ( seq-a seq-b -- seq-a ) over push-all ; inline
-
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
: args?dims ( type quot -- main-quot added-quot )
] if-empty ;
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
- return parameters fortran-sig>c-sig :> c-parameters :> c-return
+ return parameters fortran-sig>c-sig :> ( c-return c-parameters )
function fortran-name>symbol-name :> c-function
[args>args]
c-return library c-function c-parameters \ alien-invoke
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser
+USING: accessors arrays assocs classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
combinators effects.parser fry functors.backend generic
generic.parser interpolate io.streams.string kernel lexer
M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum )
- parse-definition >fake-quotations parsed
- [ fake-quotations> first ] over push-all ;
+ parse-definition >fake-quotations suffix!
+ [ fake-quotations> first ] append! ;
: parse-declared* ( accum -- accum )
complete-effect
[ parse-definition* ] dip
- parsed ;
+ suffix! ;
FUNCTOR-SYNTAX: TUPLE:
- scan-param parsed
+ scan-param suffix!
scan {
- { ";" [ tuple parsed f parsed ] }
- { "<" [ scan-param parsed [ parse-tuple-slots ] { } make parsed ] }
+ { ";" [ tuple suffix! f suffix! ] }
+ { "<" [ scan-param suffix! [ parse-tuple-slots ] { } make suffix! ] }
[
- [ tuple parsed ] dip
+ [ tuple suffix! ] dip
[ parse-slot-name [ parse-tuple-slots ] when ] { }
- make parsed
+ make suffix!
]
} case
- \ define-tuple-class parsed ;
+ \ define-tuple-class suffix! ;
FUNCTOR-SYNTAX: SINGLETON:
- scan-param parsed
- \ define-singleton-class parsed ;
+ scan-param suffix!
+ \ define-singleton-class suffix! ;
FUNCTOR-SYNTAX: MIXIN:
- scan-param parsed
- \ define-mixin-class parsed ;
+ scan-param suffix!
+ \ define-mixin-class suffix! ;
FUNCTOR-SYNTAX: M:
- scan-param parsed
- scan-param parsed
- [ create-method-in dup method-body set ] over push-all
+ scan-param suffix!
+ scan-param suffix!
+ [ create-method-in dup method-body set ] append!
parse-definition*
- \ define* parsed ;
+ \ define* suffix! ;
FUNCTOR-SYNTAX: C:
- scan-param parsed
- scan-param parsed
+ scan-param suffix!
+ scan-param suffix!
complete-effect
- [ [ [ boa ] curry ] over push-all ] dip parsed
- \ define-declared* parsed ;
+ [ [ [ boa ] curry ] append! ] dip suffix!
+ \ define-declared* suffix! ;
FUNCTOR-SYNTAX: :
- scan-param parsed
+ scan-param suffix!
parse-declared*
- \ define-declared* parsed ;
+ \ define-declared* suffix! ;
FUNCTOR-SYNTAX: SYMBOL:
- scan-param parsed
- \ define-symbol parsed ;
+ scan-param suffix!
+ \ define-symbol suffix! ;
FUNCTOR-SYNTAX: SYNTAX:
- scan-param parsed
+ scan-param suffix!
parse-definition*
- \ define-syntax parsed ;
+ \ define-syntax suffix! ;
FUNCTOR-SYNTAX: INSTANCE:
- scan-param parsed
- scan-param parsed
- \ add-mixin-instance parsed ;
+ scan-param suffix!
+ scan-param suffix!
+ \ add-mixin-instance suffix! ;
FUNCTOR-SYNTAX: GENERIC:
- scan-param parsed
- complete-effect parsed
- \ define-simple-generic* parsed ;
+ scan-param suffix!
+ complete-effect suffix!
+ \ define-simple-generic* suffix! ;
FUNCTOR-SYNTAX: MACRO:
- scan-param parsed
+ scan-param suffix!
parse-declared*
- \ define-macro parsed ;
+ \ define-macro suffix! ;
- FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
+ FUNCTOR-SYNTAX: inline [ word make-inline ] append! ;
- FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
+ FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } suffix! ;
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
- '[ _ with-string-writer @ ] parsed ;
+ '[ _ with-string-writer @ ] suffix! ;
PRIVATE>
: pop-functor-words ( -- )
functor-words unuse-words ;
+: (parse-bindings) ( end -- )
+ dup parse-binding dup [
+ first2 [ make-local ] dip 2array ,
+ (parse-bindings)
+ ] [ 2drop ] if ;
+
+: with-bindings ( quot -- words assoc )
+ '[
+ in-lambda? on
+ _ H{ } make-assoc
+ ] { } make swap ; inline
+
+: parse-bindings ( end -- words assoc )
+ [
+ namespace use-words
+ (parse-bindings)
+ namespace unuse-words
+ ] with-bindings ;
+
: parse-functor-body ( -- form )
push-functor-words
- "WHERE" parse-bindings*
- [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
+ "WHERE" parse-bindings
+ [ [ swap <def> suffix ] { } assoc>map concat ]
+ [ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) ] bi*
+ [ ] append-as
pop-functor-words ;
: (FUNCTOR:) ( -- word def effect )
] dip set-at ;
: xml>gb-data ( stream -- mapping ranges )
- [let | mapping [ H{ } clone ] ranges [ V{ } clone ] |
+ [let
+ H{ } clone :> mapping V{ } clone :> ranges
[
dup contained? [
dup name>> main>> {
[ 2drop ]
} case
] [ drop ] if
- ] each-element mapping ranges
+ ] each-element mapping ranges
] ;
: unlinear ( num -- bytes )
126 /mod HEX: 81 + swap
10 /mod HEX: 30 + swap
HEX: 81 +
- 4byte-array dup reverse-here ;
+ 4byte-array reverse! ;
: >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
'[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
SYNTAX: :>
scan locals get [ :>-outside-lambda-error ] unless*
- parse-def parsed ;
- [ make-local ] bind <def> suffix! ;
++ parse-def suffix! ;
- SYNTAX: [| parse-lambda over push-all ;
+ SYNTAX: [| parse-lambda append! ;
- SYNTAX: [let parse-let over push-all ;
+ SYNTAX: [let parse-let append! ;
-SYNTAX: [let* parse-let* append! ;
-
-SYNTAX: [wlet parse-wlet append! ;
-
SYNTAX: :: (::) define-declared ;
SYNTAX: M:: (M::) define ;
words ;
IN: locals.rewrite.sugar
-! Step 1: rewrite [| [let [let* [wlet into :> forms, turn
+! Step 1: rewrite [| into :> forms, turn
! literals with locals in them into code which constructs
! the literal after pushing locals on the stack
M: lambda rewrite-element rewrite-sugar* ;
-M: binding-form rewrite-element binding-form-in-literal-error ;
+M: let rewrite-element let-form-in-literal-error ;
M: local rewrite-element , ;
M: def rewrite-sugar* , ;
+M: multi-def rewrite-sugar* locals>> <reversed> [ <def> , ] each ;
+
M: hashtable rewrite-sugar* rewrite-element ;
M: wrapper rewrite-sugar*
rewrite-wrapper ;
M: word rewrite-sugar*
- dup { load-locals get-local drop-locals } memq?
+ dup { load-locals get-local drop-locals } member-eq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object rewrite-sugar* , ;
-: let-rewrite ( body bindings -- )
- [ quotation-rewrite % <def> , ] assoc-each
- quotation-rewrite % ;
-
M: let rewrite-sugar*
- [ body>> ] [ bindings>> ] bi let-rewrite ;
-
-M: let* rewrite-sugar*
- [ body>> ] [ bindings>> ] bi let-rewrite ;
-
-M: wlet rewrite-sugar*
- [ body>> ] [ bindings>> ] bi
- [ '[ _ ] ] assoc-map
- let-rewrite ;
+ body>> quotation-rewrite % ;
<PRIVATE
: float-type? ( c-type -- ? )
- { float double } memq? ;
+ { float double } member-eq? ;
: unsigned-type? ( c-type -- ? )
- { uchar ushort uint ulonglong } memq? ;
+ { uchar ushort uint ulonglong } member-eq? ;
: check-vconvert-type ( value expected-type -- value )
2dup instance? [ drop ] [ bad-vconvert-input ] if ; inline
PRIVATE>
MACRO:: vconvert ( from-type to-type -- )
- from-type new [ element-type ] [ byte-length ] bi :> from-length :> from-element
- to-type new [ element-type ] [ byte-length ] bi :> to-length :> to-element
+ from-type new [ element-type ] [ byte-length ] bi :> ( from-element from-length )
+ to-type new [ element-type ] [ byte-length ] bi :> ( to-element to-length )
from-element heap-size :> from-size
to-element heap-size :> to-size
drop \r
] [ \r
[\r
- "FROM: locals => [let* ; FROM: sequences => nth ; [let* | " %\r
- dup length swap [\r
- dup ebnf-var? [\r
+ "FROM: locals => [let :> ; FROM: sequences => nth ; [let " %\r
+ dup length [\r
+ over ebnf-var? [\r
+ " " % # " over nth :> " %\r
name>> % \r
- " [ " % # " over nth ] " %\r
] [\r
2drop\r
] if\r
] 2each\r
- " | " %\r
+ " " %\r
% \r
" nip ]" % \r
] "" make \r
\r
M: ebnf-var build-locals ( code ast -- )\r
[\r
- "FROM: locals => [let* ; FROM: kernel => dup nip ; [let* | " %\r
- name>> % " [ dup ] " %\r
- " | " %\r
+ "FROM: locals => [let :> ; FROM: kernel => dup nip ; [let " %\r
+ " dup :> " % name>> %\r
+ " " %\r
% \r
" nip ]" % \r
] "" make ;\r
SYNTAX: <EBNF\r
"EBNF>"\r
reset-tokenizer parse-multiline-string parse-ebnf main swap at \r
- parsed reset-tokenizer ;\r
+ suffix! reset-tokenizer ;\r
\r
SYNTAX: [EBNF\r
"EBNF]"\r
reset-tokenizer parse-multiline-string ebnf>quot nip \r
- parsed \ call parsed reset-tokenizer ;\r
+ suffix! \ call suffix! reset-tokenizer ;\r
\r
SYNTAX: EBNF: \r
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string \r
l lrstack get (setup-lr) ;
:: lr-answer ( r p m -- ast )
- [let* |
- h [ m ans>> head>> ]
- |
+ m ans>> head>> :> h
h rule-id>> r rule-id eq? [
m ans>> seed>> m (>>ans)
m ans>> failed? [
] if
] [
m ans>> seed>>
- ] if
- ] ; inline
+ ] if ; inline
:: recall ( r p -- memo-entry )
- [let* |
- m [ p r rule-id memo ]
- h [ p heads at ]
- |
+ p r rule-id memo :> m
+ p heads at :> h
h [
m r rule-id h involved-set>> h rule-id>> suffix member? not and [
fail p memo-entry boa
] if
] [
m
- ] if
- ] ; inline
+ ] if ; inline
:: apply-non-memo-rule ( r p -- ast )
- [let* |
- lr [ fail r rule-id f lrstack get left-recursion boa ]
- m [ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo ]
- ans [ r eval-rule ]
- |
+ fail r rule-id f lrstack get left-recursion boa :> lr
+ lr lrstack set lr p memo-entry boa dup p r rule-id set-memo :> m
+ r eval-rule :> ans
lrstack get next>> lrstack set
pos get m (>>pos)
lr head>> [
] [
ans m (>>ans)
ans
- ] if
- ] ; inline
+ ] if ; inline
: apply-memo-rule ( r m -- ast )
[ ans>> ] [ pos>> ] bi pos set
ERROR: parse-failed input word ;
SYNTAX: PEG:
- (:)
- [let | effect [ ] def [ ] word [ ] |
- [
- [
- [let | compiled-def [ def call compile ] |
+ [let
+ (:) :> ( word def effect )
+ [
[
- dup compiled-def compiled-parse
- [ ast>> ] [ word parse-failed ] ?if
- ]
- word swap effect define-declared
- ]
- ] with-compilation-unit
- ] append!
- ] ;
+ def call compile :> compiled-def
+ [
+ dup compiled-def compiled-parse
+ [ ast>> ] [ word parse-failed ] ?if
+ ]
+ word swap effect define-declared
+ ] with-compilation-unit
- ] over push-all
++ ] append!
+ ] ;
USING: vocabs vocabs.loader ;
: parse-decimal ( -- decimal ) scan string>decimal ;
- SYNTAX: D: parse-decimal parsed ;
+ SYNTAX: D: parse-decimal suffix! ;
: decimal>ratio ( decimal -- ratio ) >decimal< 10^ * ;
: decimal>float ( decimal -- ratio ) decimal>ratio >float ;
:: D/ ( D1 D2 a -- D3 )
D1 D2 guard-decimals 2drop
- D1 >decimal< :> e1 :> m1
- D2 >decimal< :> e2 :> m2
+ D1 >decimal< :> ( m1 e1 )
+ D2 >decimal< :> ( m2 e2 )
m1 a 10^ *
m2 /i
PRIVATE>
SYNTAX: [infix
- "infix]" [infix-parse parsed \ call parsed ;
+ "infix]" [infix-parse suffix! \ call suffix! ;
-
-<PRIVATE
-
-: parse-infix-locals ( assoc end -- quot )
- '[ _ [infix-parse prepare-operand ] ((parse-lambda)) ;
-
-PRIVATE>
-
-SYNTAX: [infix|
- "|" parse-bindings "infix]" parse-infix-locals <let>
- ?rewrite-closures append! ;
projects / factor.git / commitdiff