steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

parse-k updates

cvs
Daniel Ehrenberg 2005-08-25 22:02:30 +00:00
parent 45109c1a0a
commit 2ca86efb1d
1 changed files with 58 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
contrib/algebra/parse-k.factor
View File

@ -1,23 +1,14 @@
IN: infix IN: infix
USING: sequences kernel math strings combinators namespaces prettyprint io inspector USING: sequences kernel io math strings combinators namespaces prettyprint
errors parser generic lists kernel-internals hashtables words vectors ; errors parser generic lists kernel-internals hashtables words vectors ;
! remove: inspector
! Tokenizer ! Tokenizer
PREDICATE: fixnum num-char "0123456789." member? ;
PREDICATE: fixnum special-char ";!@#$%^&*?/|\\=+_-" member? ;
PREDICATE: fixnum opener-char "([{" member? ;
PREDICATE: fixnum closer-char "}])" member? ;
PREDICATE: fixnum apost CHAR: ' = ;
TUPLE: tok char ; TUPLE: tok char ;
TUPLE: brackets seq ender ; TUPLE: brackets seq ender ;
PREDICATE: symbol apostrophe SYMBOL: apostrophe
#! placeholder
apostrophe = ;
SYMBOL: code #! Source code SYMBOL: code #! Source code
SYMBOL: spot #! Current index of string SYMBOL: spot #! Current index of string
@ -50,33 +41,29 @@ SYMBOL: spot #! Current index of string
: parse-num ( -- number ) : parse-num ( -- number )
#! Take a number from code, advancing spot and #! Take a number from code, advancing spot and
#! returning the number. #! returning the number.
[ num-char? not ] take-until parse-number ; [ "0123456789." member? not ] take-until string>number ;
GENERIC: token ( list char -- list )
#! Given the first character, decide how to get the
#! next token
: get-token ( -- char ) : get-token ( -- char )
spot get code get nth ; spot get code get nth ;
DEFER: token
: next-token ( list -- list ) : next-token ( list -- list )
#! Take one token from code and return it #! Take one token from code and return it
parse-blank not-done? [ parse-blank not-done? [
get-token token get-token token
] when ; ] when ;
M: letter token : token
drop parse-var swons next-token ; {
M: num-char token { [ dup letter? ] [ drop parse-var swons ] }
drop parse-num swons next-token ; { [ dup "0123456789." member? ] [ drop parse-num swons ] }
M: special-char token { [ dup ";!@#$%^&*?/|\\=+_-~" member? ] [ <tok> swons incr-spot ] }
<tok> swons incr-spot next-token ; { [ dup "([{" member? ] [ drop f incr-spot ] }
M: opener-char token { [ dup ")]}" member? ] [ <brackets> swons incr-spot ] }
drop f incr-spot next-token ; { [ dup CHAR: ' = ] [ drop apostrophe swons incr-spot ] }
M: closer-char token { [ t ] [ "Bad character " swap ch>string append throw ] }
<brackets> swons incr-spot next-token ; } cond next-token ;
M: apost token
drop apostrophe swons incr-spot next-token ;
: tokenize ( string -- tokens ) : tokenize ( string -- tokens )
#! Tokenize a string, returning a list of tokens #! Tokenize a string, returning a list of tokens
@ -86,14 +73,8 @@ M: apost token
] with-scope ; ] with-scope ;
! Parser ! Parser
PREDICATE: tok operator
#! A normal operator, like +
tok-char "!@#$%^&*?/|=+_-" member? ;
TUPLE: apply func args ; TUPLE: apply func args ;
#! Function application #! Function application
C: apply C: apply
@ -107,9 +88,6 @@ UNION: value number string ;
#! The semicolon token #! The semicolon token
<< tok f CHAR: ; >> ; << tok f CHAR: ; >> ;
PREDICATE: tok semicol
semicolon = ;
: nest-apply ( [ ast ] -- apply ) : nest-apply ( [ ast ] -- apply )
unswons unit swap [ unswons unit swap [
swap <apply> unit swap <apply> unit
@ -126,21 +104,12 @@ DEFER: parse-tokens
M: value parse-token M: value parse-token
swapd swons swap ; swapd swons swap ;
: case ( value quot-alist -- )
#! This is evil. It's just like Joy's case but there's
#! no default. [ ] case is equivalent to drop
assoc call ;
M: brackets parse-token M: brackets parse-token
swapd dup brackets-seq swap brackets-ender [ swapd dup brackets-seq swap brackets-ender {
[ CHAR: ] { [ dup CHAR: ] = ] [ drop semicolon-split >r unswons r> <apply> swons ] }
semicolon-split >r unswons r> <apply> swons { [ dup CHAR: } = ] [ drop semicolon-split >vector swons ] }
] [ CHAR: } { [ CHAR: ) = ] [ reverse parse-tokens swons ] }
semicolon-split >vector swons } cond swap ;
] [ CHAR: )
reverse parse-tokens swons
]
] case swap ;
M: object tok-char drop -1 ; ! Hack! M: object tok-char drop -1 ; ! Hack!
@ -157,10 +126,10 @@ M: string tok>string ;
tok>string -rot nip tok>string -rot nip
parse-tokens unit <apply> unit ; parse-tokens unit <apply> unit ;
: apost-op ( ast tokens token -- ast ) : null-op ( ast tokens token -- ast )
nip tok-char ch>string swons ; nip tok-char ch>string swons ;
M: operator parse-token M: tok parse-token
over [ over [
pick [ pick [
binary-op binary-op
@ -168,11 +137,13 @@ M: operator parse-token
unary-op unary-op
] ifte ] ifte
] [ ] [
apost-op null-op
] ifte f ; ] ifte f ;
M: apostrophe parse-token ( ast tokens token -- ast tokens )
drop unswons >r parse-tokens >r car r> 2list r>
M: symbol parse-token ! apostrophe
drop unswons >r parse-tokens >r unswons r> 2list r>
unit parse-tokens swap <apply> swons f ; unit parse-tokens swap <apply> swons f ;
: (parse-tokens) ( ast tokens -- ast ) : (parse-tokens) ( ast tokens -- ast )
@ -213,7 +184,7 @@ M: comp-literal compile-ast ! literal numbers
: seq-stupid-all? ( seq pred -- ? ) : seq-stupid-all? ( seq pred -- ? )
t -rot [ call and ] cons each ; inline t -rot [ call and ] cons each ; inline
: accumulator ( vars { asts } closer -- quot ) : accumulator ( vars { asts } quot -- quot )
-rot [ -rot [
[ [
\ dup , \ dup ,
@ -247,8 +218,6 @@ M: vector compile-ast ! literal vectors
#! Regular functions #! Regular functions
#! Gives quotation applicable to stack #! Gives quotation applicable to stack
{{ {{
[ [[ "sin" 1 ]] sin ]
[ [[ "cos" 1 ]] cos ]
[ [[ "+" 2 ]] + ] [ [[ "+" 2 ]] + ]
[ [[ "-" 2 ]] - ] [ [[ "-" 2 ]] - ]
[ [[ ">" 2 ]] [ > ] infix-relation ] [ [[ ">" 2 ]] [ > ] infix-relation ]
@ -258,13 +227,30 @@ M: vector compile-ast ! literal vectors
[ [[ "~" 1 ]] not ] [ [[ "~" 1 ]] not ]
[ [[ "&" 2 ]] and ] [ [[ "&" 2 ]] and ]
[ [[ "|" 2 ]] or ] [ [[ "|" 2 ]] or ]
[ [[ "&" 1 ]] t [ and ] reduce ]
[ [[ "|" 1 ]] f [ or ] reduce ]
[ [[ "*" 2 ]] * ] [ [[ "*" 2 ]] * ]
[ [[ "log" 1 ]] log ] [ [[ "ln" 1 ]] log ]
[ [[ "plusmin" 2 ]] [ + ] 2keep - ] [ [[ "plusmin" 2 ]] [ + ] 2keep - ]
[ [[ "@" 2 ]] swap nth ] [ [[ "@" 2 ]] swap nth ]
[ [[ "sqrt" 1 ]] sqrt ] [ [[ "sqrt" 1 ]] sqrt ]
[ [[ "/" 2 ]] / ] [ [[ "/" 2 ]] / ]
[ [[ "^" 2 ]] ^ ] [ [[ "^" 2 ]] ^ ]
[ [[ "#" 1 ]] length ]
[ [[ "eq" 2 ]] eq? ]
[ [[ "*" 1 ]] first ]
[ [[ "+" 1 ]] flip ]
[ [[ "\\" 1 ]] <reversed> ]
[ [[ "sin" 1 ]] sin ]
[ [[ "cos" 1 ]] cos ]
[ [[ "tan" 1 ]] tan ]
[ [[ "max" 2 ]] max ]
[ [[ "min" 2 ]] min ]
[ [[ "," 2 ]] append ]
[ [[ "," 1 ]] concat ]
[ [[ "sn" 3 ]] -rot set-nth ]
[ [[ "prod" 1 ]] product ]
[ [[ "vec" 1 ]] >vector ]
}} ; }} ;
: drc ( list -- list ) : drc ( list -- list )
@ -282,11 +268,15 @@ M: vector compile-ast ! literal vectors
#! Higher-order functions #! Higher-order functions
#! Gives quotation applicable to quotation and rest of stack #! Gives quotation applicable to quotation and rest of stack
{{ {{
[ [[ "each" 2 ]] 2map ] [ [[ "!" 2 ]] 2map ]
[ [[ "each" 1 ]] map ] [ [[ "!" 1 ]] map ]
[ [[ "right" 2 ]] map-with ] [ [[ ">" 2 ]] map-with ]
[ [[ "left" 2 ]] map-with-left ] [ [[ "<" 2 ]] map-with-left ]
[ [[ "^" 1 ]] all? ]
[ [[ "~" 1 ]] call not ]
[ [[ "~" 2 ]] call not ]
[ [[ "/" 2 ]] swapd reduce ]
[ [[ "\\" 2 ]] swapd accumulate ]
}} ; }} ;
: get-hash ( key table -- value ) : get-hash ( key table -- value )
@ -310,7 +300,7 @@ M: vector compile-ast ! literal vectors
>apply< length swap make-apply ; >apply< length swap make-apply ;
M: apply compile-ast ! function application M: apply compile-ast ! function application
[ apply-args [ swap ] accumulator drc [ nip ] append ] keep [ apply-args [ swap ] accumulator [ drop ] append ] keep
get-function append ; get-function append ;
: push-list ( list item -- list ) : push-list ( list item -- list )
@ -333,7 +323,7 @@ M: apply compile-ast ! function application
over prologue -rot compile-ast append ; over prologue -rot compile-ast append ;
: define-math ( string -- ) : define-math ( string -- )
dup parse-full apply-args 2unlist swap dup parse-full apply-args uncons car swap
>apply< >r create-in r> >apply< >r create-in r>
[ "math-args" set-word-prop ] 2keep [ "math-args" set-word-prop ] 2keep
>r tuck >r >r swap "code" set-word-prop r> r> r> >r tuck >r >r swap "code" set-word-prop r> r> r>
@ -351,7 +341,7 @@ M: apply compile-ast ! function application
#! Executes and prints the result of a math #! Executes and prints the result of a math
#! expression at parsetime #! expression at parsetime
string-mode on [ string-mode on [
concat/spaces string-mode off parse-full " " join string-mode off parse-full
f swap ast>quot call . f swap ast>quot call .
] f ; parsing ] f ; parsing
@ -368,15 +358,6 @@ M: apply compile-ast ! function application
! PREDICATE: word compound ! PREDICATE: word compound
! dup word-primitive 1 = swap infix-word? not and ; ! dup word-primitive 1 = swap infix-word? not and ;
: (watch-after) ( word def -- def )
[ % "<== " , \ write , word-name , \ print , \ .s , ] make-list ;
: watch-after ( word -- )
[ (watch-after) ] annotate ;
: watch-all ( word -- )
dup watch watch-after ;
MATH: quadratic[a;b;c] = MATH: quadratic[a;b;c] =