Paste: joy
Author: | inforichland |
Mode: | factor |
Date: | Mon, 3 Aug 2009 04:27:56 |
Plain Text |
USING: kernel namespaces sequences accessors
joy.ast joy.parser joy.pprint vectors
combinators math assocs math.ranges random
quotations prettyprint math.functions
calendar math.order macros generalizations fry
parser words stack-checker ;
IN: joy.eval
TUPLE: joy-env env { dstack vector } { rstack vector } ;
SYMBOL: joy
MACRO: preserving
[ infer in>> length ] keep '[ _ ndup @ ] ;
: ifte
[ preserving ] 2dip if ; inline
: default-env
[ ] H{ } make-assoc ;
: dstack-empty?
joy get dstack>> empty? ;
: dstack-push
joy get dstack>> push ;
: dstack-pop*
joy get dstack>> pop ;
: dstack-pop
dstack-pop* drop ; inline
: eval-identifier
joy get env>> at
[ call ] [ "Invalid word!" throw ] if* ; inline
: add-word-to-env
[ first ] [ second ] bi
joy get env>> set-at ;
GENERIC: (@eval)
M: ast-string (@eval)
string>> dstack-push ; inline
M: ast-number (@eval)
num>> dstack-push ; inline
M: ast-character (@eval)
char>> dstack-push ; inline
M: ast-identifier (@eval)
name>> eval-identifier ; inline
M: ast-quotation (@eval)
body>> >quotation dstack-push ; inline
M: ast-special (@eval)
value>> eval-identifier ; inline
M: ast-boolean (@eval)
value>> dstack-push ; inline
: unop
dstack-pop*
swap call
dstack-push ; inline
: binop
dstack-pop*
dstack-pop* swap
rot call
dstack-push ; inline
: dup-joy
dstack-pop* dup
dstack-push
dstack-push ; inline
: swap-joy
dstack-pop* dstack-pop*
swap
dstack-push dstack-push ; inline
: (dip-joy)
dstack-pop*
[ [ (@eval) ] each ] dip
dstack-push ; inline
: dip-joy
dstack-pop* dup
quotation?
[ (dip-joy) ] [ drop "Not a quotation!" throw ] if ; inline
: rollup-joy
dstack-pop* dstack-pop* dstack-pop*
[ swap ] dip swap
dstack-push dstack-push dstack-push ; inline
: rolldown-joy
dstack-pop* dstack-pop* dstack-pop*
swap [ swap ] dip
dstack-push dstack-push dstack-push ; inline
: rotate-joy
dstack-pop* dstack-pop* dstack-pop*
[ swap ] dip swap [ swap ] dip
dstack-push dstack-push dstack-push ; inline
: dupd-joy dstack-pop* dup-joy dstack-push ; inline
: swapd-joy dstack-pop* swap-joy dstack-push ; inline
: rollupd-joy dstack-pop* rollup-joy dstack-push ; inline
: rolldownd-joy dstack-pop* rolldown-joy dstack-push ; inline
: rotated-joy dstack-pop* rotate-joy dstack-push ; inline
: pop-joy dstack-pop ; inline
: popd-joy dstack-pop* pop-joy dstack-push ; inline
: print-joy dstack-pop* pprint ; inline
: or-joy
dstack-pop* dstack-pop*
{
{ [ dup boolean? ] [ or dstack-push ] }
{ [ dup number? ] [ [ 0 = ] bi@ and not dstack-push ] }
[ 2drop "Invalid operands for 'or'!" throw ]
} cond ; inline
: and-joy
dstack-pop* dstack-pop*
{
{ [ dup boolean? ] [ and dstack-push ] }
{ [ dup number? ] [ [ 0 = ] bi@ or not dstack-push ] }
[ 2drop "Invalid operands for 'and'!" throw ]
} cond ; inline
: xor-joy
dstack-pop* dstack-pop*
{
{ [ dup boolean? ] [ xor dstack-push ] }
{ [ dup number? ] [ = not dstack-push ] }
[ 2drop "Invalid operands for 'xor'!" throw ]
} cond ; inline
: false-joy f dstack-push ; inline
: true-joy t dstack-push ; inline
: rand-joy 1 32767 [a,b] random dstack-push ; inline
: id-joy ; inline
: time-joy
now
1970 1 1 0 0 0 0 hours <timestamp>
time- duration>seconds floor dstack-push ; inline
: (sign)
{
{ [ dup 0 > ] [ drop 1 ] }
{ [ dup 0 < ] [ drop -1 ] }
[ drop 0 ]
} cond ; inline
: sign-joy [ (sign) ] unop ; inline
: neg-joy [ 0 swap - ] unop ; inline
: abs-joy [ abs ] unop ; inline
: cos-joy [ cos ] unop ; inline
: sin-joy [ sin ] unop ; inline
: tan-joy [ tan ] unop ; inline
: acos-joy [ acos ] unop ; inline
: asin-joy [ asin ] unop ; inline
: atan-joy [ atan ] unop ; inline
: cosh-joy [ cosh ] unop ; inline
: sinh-joy [ sinh ] unop ; inline
: tanh-joy [ tanh ] unop ; inline
: +-joy [ + ] binop ; inline
: --joy [ - ] binop ; inline
: *-joy [ * ] binop ; inline
: /-joy [ / ] binop ; inline
: rem-joy [ mod ] binop ; inline
: div-joy [ /mod ] binop dstack-push ; inline
: ceil-joy [ ceiling ] unop ; inline
: floor-joy [ floor ] unop ; inline
: exp-joy [ exp ] unop ; inline
: trunc-joy [ truncate ] unop ; inline
: pred-joy [ 1 - ] unop ; inline
: succ-joy [ 1 + ] unop ; inline
: max-joy [ max ] binop ; inline
: min-joy [ min ] binop ; inline
: (env)
joy-env new default-env >>env
V{ } clone >>dstack
V{ } clone >>rstack
joy set ;
: env
(env)
{
{ [ +-joy ] "+" }
{ [ --joy ] "-" }
{ [ *-joy ] "*" }
{ [ /-joy ] "/" }
{ [ rand-joy ] "rand" }
{ [ time-joy ] "time" }
{ [ dup-joy ] "dup" }
{ [ swap-joy ] "swap" }
{ [ dip-joy ] "dip" }
{ [ pop-joy ] "pop" }
{ [ print-joy ] "." }
{ [ rollup-joy ] "rollup" }
{ [ rolldown-joy ] "rolldown" }
{ [ rotate-joy ] "rotate" }
{ [ dupd-joy ] "dupd" }
{ [ swapd-joy ] "swapd" }
{ [ rollupd-joy ] "rollupd" }
{ [ rolldownd-joy ] "rolldownd" }
{ [ rotated-joy ] "rotated" }
{ [ popd-joy ] "popd" }
{ [ id-joy ] "id" }
{ [ or-joy ] "or" }
{ [ and-joy ] "and" }
{ [ xor-joy ] "xor" }
{ [ rem-joy ] "rem" }
{ [ div-joy ] "div" }
{ [ sign-joy ] "sign" }
{ [ neg-joy ] "neg" }
{ [ ceil-joy ] "ceil" }
{ [ floor-joy ] "floor" }
{ [ abs-joy ] "abs" }
{ [ exp-joy ] "exp" }
{ [ trunc-joy ] "trunc" }
{ [ pred-joy ] "pred" }
{ [ succ-joy ] "succ" }
{ [ max-joy ] "max" }
{ [ min-joy ] "min" }
{ [ cos-joy ] "cos" }
{ [ sin-joy ] "sin" }
{ [ tan-joy ] "tan" }
{ [ cosh-joy ] "cosh" }
{ [ sinh-joy ] "sinh" }
{ [ tanh-joy ] "tanh" }
{ [ acos-joy ] "acos" }
{ [ asin-joy ] "asin" }
{ [ atan-joy ] "atan" }
} [ add-word-to-env ] each ;
: (eval)
parse-joy
[ (@eval) ] each ;
: eval
env
(eval) ;
New Annotation