initial commit of parse-k.factor
Daniel Ehrenberg
parent
57bedd8139
commit
c3540aaf7a
|
|
@ -0,0 +1,383 @@
|
|||
IN: parse-k
|
||||
USING: sequences kernel math strings combinators namespaces prettyprint io inspector
|
||||
errors parser generic lists kernel-internals hashtables words vectors ;
|
||||
! remove: inspector
|
||||
|
||||
! 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: brackets seq ender ;
|
||||
|
||||
PREDICATE: symbol apostrophe
|
||||
#! placeholder
|
||||
apostrophe = ;
|
||||
|
||||
SYMBOL: code #! Source code
|
||||
SYMBOL: spot #! Current index of string
|
||||
|
||||
: take-until ( quot -- parsed-stuff | quot: char -- ? )
|
||||
#! Take the substring of a string starting at spot
|
||||
#! from code until the quotation given is true and
|
||||
#! advance spot to after the substring.
|
||||
>r spot get code get 2dup r>
|
||||
skip [ swap subseq ] keep
|
||||
spot set ;
|
||||
|
||||
: parse-blank ( -- )
|
||||
#! Advance code past any whitespace, including newlines
|
||||
spot get code get [ blank? not ] skip spot set ;
|
||||
|
||||
: not-done? ( -- ? )
|
||||
#! Return t if spot is not at the end of code
|
||||
code get length spot get = not ;
|
||||
|
||||
: incr-spot ( -- )
|
||||
#! Increment spot.
|
||||
spot [ 1 + ] change ;
|
||||
|
||||
: parse-var ( -- variable-name )
|
||||
#! Take a series of letters from code, advancing
|
||||
#! spot and returning the letters.
|
||||
[ letter? not ] take-until ;
|
||||
|
||||
: parse-num ( -- number )
|
||||
#! Take a number from code, advancing spot and
|
||||
#! returning the number.
|
||||
[ num-char? not ] take-until parse-number ;
|
||||
|
||||
GENERIC: token ( list char -- list )
|
||||
#! Given the first character, decide how to get the
|
||||
#! next token
|
||||
|
||||
: get-token ( -- char )
|
||||
spot get code get nth ;
|
||||
|
||||
: next-token ( list -- list )
|
||||
#! Take one token from code and return it
|
||||
parse-blank not-done? [
|
||||
get-token token
|
||||
] when ;
|
||||
|
||||
M: letter token
|
||||
drop parse-var swons next-token ;
|
||||
M: num-char token
|
||||
drop parse-num swons next-token ;
|
||||
M: special-char token
|
||||
<tok> swons incr-spot next-token ;
|
||||
M: opener-char token
|
||||
drop f incr-spot next-token ;
|
||||
M: closer-char token
|
||||
<brackets> swons incr-spot next-token ;
|
||||
M: apost token
|
||||
drop apostrophe swons incr-spot next-token ;
|
||||
|
||||
: tokenize ( string -- tokens )
|
||||
#! Tokenize a string, returning a list of tokens
|
||||
[
|
||||
code set 0 spot set
|
||||
f next-token reverse
|
||||
] with-scope ;
|
||||
|
||||
|
||||
|
||||
|
||||
! Parser
|
||||
|
||||
PREDICATE: tok operator
|
||||
#! A normal operator, like +
|
||||
tok-char "!@#$%^&*?/|=+_-" member? ;
|
||||
|
||||
TUPLE: apply func args ;
|
||||
#! Function application
|
||||
C: apply
|
||||
>r [ ] subset r>
|
||||
[ set-apply-args ] keep
|
||||
[ set-apply-func ] keep ;
|
||||
|
||||
UNION: value number string ;
|
||||
|
||||
: semicolon ( -- semicolon )
|
||||
#! The semicolon token
|
||||
<< tok f CHAR: ; >> ;
|
||||
|
||||
PREDICATE: tok semicol
|
||||
semicolon = ;
|
||||
|
||||
: nest-apply ( [ ast ] -- apply )
|
||||
unswons unit swap [
|
||||
swap <apply> unit
|
||||
] each car ;
|
||||
|
||||
GENERIC: parse-token ( ast tokens token -- ast tokens )
|
||||
#! Take one or more tokens
|
||||
|
||||
DEFER: parse-tokens
|
||||
|
||||
: semicolon-split ( list -- [ ast ] )
|
||||
reverse semicolon unit split [ parse-tokens ] map ;
|
||||
|
||||
M: value parse-token
|
||||
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
|
||||
swapd dup brackets-seq swap brackets-ender [
|
||||
[ CHAR: ]
|
||||
semicolon-split >r unswons r> <apply> swons
|
||||
] [ CHAR: }
|
||||
semicolon-split >vector swons
|
||||
] [ CHAR: )
|
||||
reverse parse-tokens swons
|
||||
]
|
||||
] case swap ;
|
||||
|
||||
M: object tok-char drop -1 ; ! Hack!
|
||||
|
||||
GENERIC: tok>string ( token/string -- string )
|
||||
M: tok tok>string
|
||||
tok-char ch>string ;
|
||||
M: string tok>string ;
|
||||
|
||||
: binary-op ( ast tokens token -- ast )
|
||||
>r >r unswons r> parse-tokens 2list r>
|
||||
tok>string swap <apply> swons ;
|
||||
|
||||
: unary-op ( ast tokens token -- ast )
|
||||
tok>string -rot nip
|
||||
parse-tokens unit <apply> unit ;
|
||||
|
||||
: apost-op ( ast tokens token -- ast )
|
||||
nip tok-char ch>string swons ;
|
||||
|
||||
M: operator parse-token
|
||||
over [
|
||||
pick [
|
||||
binary-op
|
||||
] [
|
||||
unary-op
|
||||
] ifte
|
||||
] [
|
||||
apost-op
|
||||
] ifte f ;
|
||||
|
||||
M: apostrophe parse-token
|
||||
drop unswons >r parse-tokens >r car r> 2list r>
|
||||
unit parse-tokens swap <apply> swons f ;
|
||||
|
||||
: (parse-tokens) ( ast tokens -- ast )
|
||||
dup [
|
||||
unswons parse-token (parse-tokens)
|
||||
] [
|
||||
drop
|
||||
] ifte ;
|
||||
|
||||
: parse-tokens ( tokens -- ast )
|
||||
#! Convert a list of tokens into an AST
|
||||
f swap (parse-tokens) nest-apply ;
|
||||
|
||||
: parse-full ( string -- ast )
|
||||
#! Convert a string into an AST
|
||||
tokenize parse-tokens ;
|
||||
|
||||
|
||||
! Compiler
|
||||
|
||||
GENERIC: compile-ast ( vars ast -- quot )
|
||||
|
||||
M: string compile-ast ! variables
|
||||
swap index dup -1 = [
|
||||
"Variable not found" throw
|
||||
] [
|
||||
[ swap array-nth ] cons
|
||||
] ifte ;
|
||||
|
||||
: replace-with ( data -- [ drop data ] )
|
||||
\ drop swap 2list ;
|
||||
|
||||
UNION: comp-literal number general-list ;
|
||||
|
||||
M: comp-literal compile-ast ! literal numbers
|
||||
replace-with nip ;
|
||||
|
||||
: seq-stupid-all? ( seq pred -- ? )
|
||||
t -rot [ call and ] cons each ; inline
|
||||
|
||||
: accumulator ( vars { asts } closer -- quot )
|
||||
-rot [
|
||||
[
|
||||
\ dup ,
|
||||
compile-ast %
|
||||
dup %
|
||||
] each-with
|
||||
] make-list nip ;
|
||||
|
||||
M: vector compile-ast ! literal vectors
|
||||
dup [ number? ] seq-stupid-all? [
|
||||
replace-with nip
|
||||
] [
|
||||
[ , ] accumulator [ make-vector nip ] cons
|
||||
] ifte ;
|
||||
|
||||
: infix-relation
|
||||
#! Wraps operators like = and > so that if they're given
|
||||
#! f as either argument, they return f, and they return f if
|
||||
#! the operation yields f, but if it yields t, it returns the
|
||||
#! left argument. This way, these types of operations can be
|
||||
#! composed.
|
||||
>r 2dup and not [
|
||||
r> 3drop f
|
||||
] [
|
||||
dupd r> call [
|
||||
drop f
|
||||
] unless
|
||||
] ifte ;
|
||||
|
||||
: functions
|
||||
#! Regular functions
|
||||
#! Gives quotation applicable to stack
|
||||
{{
|
||||
[ [[ "sin" 1 ]] sin ]
|
||||
[ [[ "cos" 1 ]] cos ]
|
||||
[ [[ "+" 2 ]] + ]
|
||||
[ [[ "-" 2 ]] - ]
|
||||
[ [[ ">" 2 ]] [ > ] infix-relation ]
|
||||
[ [[ "<" 2 ]] [ < ] infix-relation ]
|
||||
[ [[ "=" 2 ]] [ = ] infix-relation ]
|
||||
[ [[ "-" 1 ]] neg ]
|
||||
[ [[ "~" 1 ]] not ]
|
||||
[ [[ "&" 2 ]] and ]
|
||||
[ [[ "|" 2 ]] or ]
|
||||
[ [[ "*" 2 ]] * ]
|
||||
[ [[ "log" 1 ]] log ]
|
||||
[ [[ "plusmin" 2 ]] [ + ] 2keep - ]
|
||||
[ [[ "@" 2 ]] swap nth ]
|
||||
[ [[ "sqrt" 1 ]] sqrt ]
|
||||
[ [[ "/" 2 ]] / ]
|
||||
[ [[ "^" 2 ]] ^ ]
|
||||
}} ;
|
||||
|
||||
: drc ( list -- list )
|
||||
#! all of list except last element (backwards cdr)
|
||||
dup cdr [
|
||||
uncons drc cons
|
||||
] [
|
||||
drop f
|
||||
] ifte ;
|
||||
|
||||
: map-with-left ( seq object quot -- seq )
|
||||
[ swapd call ] cons swapd map-with ; inline
|
||||
|
||||
: high-functions
|
||||
#! Higher-order functions
|
||||
#! Gives quotation applicable to quotation and rest of stack
|
||||
{{
|
||||
[ [[ "each" 2 ]] 2map ]
|
||||
[ [[ "each" 1 ]] map ]
|
||||
[ [[ "right" 2 ]] map-with ]
|
||||
[ [[ "left" 2 ]] map-with-left ]
|
||||
|
||||
}} ;
|
||||
|
||||
: get-hash ( key table -- value )
|
||||
#! like hash but throws exception if f
|
||||
dupd hash [ nip ] [
|
||||
[ "Key not found " write . ] string-out throw
|
||||
] ifte* ;
|
||||
|
||||
: >apply< ( apply -- func args )
|
||||
dup apply-func swap apply-args ;
|
||||
|
||||
: make-apply ( arity apply/string -- quot )
|
||||
dup string? [
|
||||
swons functions get-hash
|
||||
] [
|
||||
>apply< car >r over r> make-apply
|
||||
-rot swons high-functions get-hash cons
|
||||
] ifte ;
|
||||
|
||||
: get-function ( apply -- quot )
|
||||
>apply< length swap make-apply ;
|
||||
|
||||
M: apply compile-ast ! function application
|
||||
[ apply-args [ swap ] accumulator drc [ nip ] append ] keep
|
||||
get-function append ;
|
||||
|
||||
: push-list ( list item -- list )
|
||||
unit append ;
|
||||
|
||||
: parse-comp ( args string -- quot )
|
||||
#! Compile a string into a quotation w/o prologue
|
||||
parse-full compile-ast ;
|
||||
|
||||
: prologue ( args -- quot )
|
||||
#! Build the prolog for a function
|
||||
[
|
||||
length dup , \ <array> ,
|
||||
[ 1 - ] keep [
|
||||
2dup - [ swap set-array-nth ] cons , \ keep ,
|
||||
] repeat drop
|
||||
] make-list ;
|
||||
|
||||
: ast>quot ( args ast -- quot )
|
||||
over prologue -rot compile-ast append ;
|
||||
|
||||
: define-math ( string -- )
|
||||
dup parse-full apply-args 2unlist swap
|
||||
>apply< >r create-in r>
|
||||
[ "math-args" set-word-prop ] 2keep
|
||||
>r tuck >r >r swap "code" set-word-prop r> r> r>
|
||||
rot ast>quot define-compound ;
|
||||
|
||||
: MATH:
|
||||
#! MATH: sq[x]=x*x ;
|
||||
"in-definition" on
|
||||
string-mode on
|
||||
[
|
||||
" " join string-mode off define-math
|
||||
] f ; parsing
|
||||
|
||||
: TEST-MATH:
|
||||
#! Executes and prints the result of a math
|
||||
#! expression at parsetime
|
||||
string-mode on [
|
||||
concat/spaces string-mode off parse-full
|
||||
f swap ast>quot call .
|
||||
] f ; parsing
|
||||
|
||||
! PREDICATE: compound infix-word "code" word-prop ;
|
||||
! M: infix-word definer
|
||||
! drop POSTPONE: MATH: ;
|
||||
! M: infix-word class.
|
||||
! "code" word-prop write " ;" print ;
|
||||
!
|
||||
! Redefine compound to not include infix words so see works
|
||||
! IN: words
|
||||
! USING: kernel words parse-k ;
|
||||
!
|
||||
! PREDICATE: word compound
|
||||
! 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] =
|
||||
plusmin[(-b)/2*a;(sqrt(b^2)-4*a*c)/2*a] ;
|
||||
Loading…
Reference in New Issue