diff --git a/factor/src/core/core.factor b/factor/src/core/core.factor index 5b3ee225..1913b439 100644 --- a/factor/src/core/core.factor +++ b/factor/src/core/core.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2015 Jordan Lewis. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences arrays lists printer locals io strings malenv reader io.files io.encodings.utf8 - fry types combinators.short-circuit vectors hashtables assocs hash-sets sets grouping namespaces accessors ; + fry types combinators.short-circuit vectors hashtables assocs hash-sets sets grouping namespaces accessors + combinators readline ; IN: core @@ -30,8 +31,8 @@ CONSTANT: ns H{ { "+" [ first2 + ] } { "<=" [ first2 <= ] } { "pr-str" [ t " " pr-str-stack ] } { "str" [ f "" pr-str-stack ] } - { "prn" [ t " " pr-str-stack print nil ] } - { "println" [ f " " pr-str-stack print nil ] } + { "prn" [ t " " pr-str-stack print flush nil ] } + { "println" [ f " " pr-str-stack print flush nil ] } { "read-string" [ first read-str ] } { "slurp" [ first utf8 file-contents ] } { "cons" [ first2 swap prefix to-array ] } @@ -60,4 +61,15 @@ CONSTANT: ns H{ { "+" [ first2 + ] } { "keys" [ first keys ] } { "vals" [ first values ] } { "sequential?" [ first { [ vector? ] [ array? ] } 1|| ] } + + { "readline" [ first readline ] } + { "meta" [ first dup fn? [ meta>> ] [ drop f ] if [ nil ] unless* ] } + { "with-meta" [ first2 over fn? [ [ clone ] dip >>meta ] when ] } + { "atom" [ first ] } + { "atom?" [ first malatom? ] } + { "deref" [ first val>> ] } + { "reset!" [ first2 >>val val>> ] } + { "swap!" [ { [ first ] [ second ] [ 2 tail ] [ first val>> ] } cleave + prefix swap mal-apply get call( args fn -- maltype ) >>val val>> ] } + { "conj" [ unclip swap over array? [ reverse prepend ] [ append ] if ] } } diff --git a/factor/src/printer/printer.factor b/factor/src/printer/printer.factor index a29d0424..d03309c5 100644 --- a/factor/src/printer/printer.factor +++ b/factor/src/printer/printer.factor @@ -27,6 +27,7 @@ IN: printer { [ dup t = ] [ drop "true" ] } { [ dup f = ] [ drop "false" ] } { [ dup nil = ] [ drop "nil" ] } + { [ dup malatom? ] [ val>> readably? (pr-str) "(atom " ")" surround ] } [ summary ] } cond ; diff --git a/factor/src/stepA_mal/deploy.factor b/factor/src/stepA_mal/deploy.factor new file mode 100644 index 00000000..4397858b --- /dev/null +++ b/factor/src/stepA_mal/deploy.factor @@ -0,0 +1,16 @@ +USING: tools.deploy.config ; +H{ + { deploy-c-types? f } + { deploy-help? f } + { deploy-name "stepA_mal" } + { "stop-after-last-window?" t } + { deploy-unicode? f } + { deploy-console? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-ui? f } + { deploy-word-defs? f } + { deploy-threads? t } + { deploy-math? t } + { deploy-word-props? f } +} diff --git a/factor/src/stepA_mal/stepA_mal.factor b/factor/src/stepA_mal/stepA_mal.factor new file mode 100755 index 00000000..373de58e --- /dev/null +++ b/factor/src/stepA_mal/stepA_mal.factor @@ -0,0 +1,149 @@ +! Copyright (C) 2015 Jordan Lewis. +! See http://factorcode.org/license.txt for BSD license. +USING: io readline kernel system reader printer continuations arrays locals assocs sequences + combinators accessors fry quotations math malenv namespaces grouping hashtables lists + types core command-line combinators.short-circuit splitting prettyprint ; + +IN: stepA_mal + +SYMBOL: repl-env + +DEFER: EVAL + +: eval-ast ( ast env -- ast ) + { + { [ over malsymbol? ] [ get-or-throw ] } + { [ over sequence? ] [ '[ _ EVAL ] map ] } + { [ over assoc? ] [ '[ [ _ EVAL ] bi@ ] assoc-map ] } + [ drop ] + } cond ; + +:: eval-def! ( key value env -- maltype ) + value env EVAL [ key env set-at ] keep ; + +:: eval-defmacro! ( key value env -- maltype ) + value env EVAL t >>is-macro [ key env set-at ] keep ; + +:: eval-let* ( bindings body env -- maltype env ) + body bindings 2 group env new-env + [| env pair | pair first2 env EVAL swap env ?set-at ] + reduce ; + +:: eval-do ( exprs env -- lastform env ) + exprs empty? + [ { } f ] + [ exprs unclip-last env swap [ eval-ast ] dip nip env ] + if ; + +:: eval-if ( params env -- maltype env/f ) + { + { [ params first env EVAL { f +nil+ } index not ] ! condition is true + [ params second env ] } + { [ params length 2 > ] [ params third env ] } + [ nil f ] + } cond ; + +:: eval-fn* ( params env -- maltype ) + env params first [ name>> ] map params second ; + +:: eval-try* ( params env -- maltype ) + [ params first env EVAL ] + [ params second second env new-env ?set-at params second third swap EVAL ] + recover ; + +: args-split ( bindlist -- bindlist restbinding/f ) + [ "&" ] split dup length 1 > + [ first2 first ] + [ first f ] + if ; + +: make-bindings ( args bindlist restbinding/f -- bindingshash ) + [ swap over length cut-slice [ zip ] dip ] dip + [ swap >array 2array suffix ] + [ drop ] + if* + >hashtable ; + +: apply ( args fn -- maltype newenv/f ) + { + { [ dup fn? ] + [ [ exprs>> nip ] [ env>> nip ] [ binds>> args-split make-bindings ] 2tri ] } + { [ dup callable? ] [ call( x -- y ) f ] } + [ drop "not a fn" throw ] + } cond ; + +: is-pair? ( maltype -- bool ) + { [ sequence? ] [ empty? not ] } 1&& ; + +: quasiquote ( maltype -- maltype ) + { + { [ dup is-pair? not ] [ [ "quote" ] dip 2array ] } + { [ "unquote" over first symeq? ] [ second ] } + { [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ] + [ [ "concat" ] dip unclip second swap quasiquote 3array ] } + [ "cons" swap unclip swap [ quasiquote ] bi@ 3array ] + } cond ; + +:: is-macro-call ( maltype env -- bool ) + maltype { [ array? ] + [ first malsymbol? ] + [ first env at { [ fn? ] [ is-macro>> ] } 1&& ] + } 1&& ; + +: macro-expand ( maltype env -- maltype ) + [ 2dup is-macro-call ] + [ [ unclip ] dip get-or-throw apply [ EVAL ] keep ] + while drop ; + +: READ ( str -- maltype ) read-str ; +: EVAL ( maltype env -- maltype ) + [ dup ] + [ over array? + [ [ macro-expand ] keep + over array? + [ [ unclip ] dip swap ! rest env first + { + { [ "def!" over symeq? ] [ drop [ first2 ] dip eval-def! f ] } + { [ "defmacro!" over symeq? ] [ drop [ first2 ] dip eval-defmacro! f ] } + { [ "let*" over symeq? ] [ drop [ first2 ] dip eval-let* ] } + { [ "do" over symeq? ] [ drop eval-do ] } + { [ "if" over symeq? ] [ drop eval-if ] } + { [ "fn*" over symeq? ] [ drop eval-fn* f ] } + { [ "quote" over symeq? ] [ 2drop first f ] } + { [ "quasiquote" over symeq? ] [ drop [ first quasiquote ] dip ] } + { [ "macroexpand" over symeq? ] [ drop [ first ] dip macro-expand f ] } + { [ "try*" over symeq? ] [ drop eval-try* f ] } + [ swap [ prefix ] dip '[ _ EVAL ] map unclip apply ] + } cond ] + [ drop f ] + if ] + [ eval-ast f ] + if ] + while drop ; + +[ apply [ EVAL ] when* ] mal-apply set-global + +: PRINT ( maltype -- str ) pr-str ; +: rep ( x -- x ) [ READ repl-env get EVAL PRINT ] [ nip pr-str ] recover ; + +: main-loop ( -- ) + [ 1 ] + [ "user> " readline + [ 0 exit ] unless* + rep print flush ] + while ; + +: run-or-repl ( -- ) + command-line get dup empty? [ drop main-loop ] [ first "(load-file \"" "\")" surround rep print flush ] if ; + +f ns repl-env set-global + +[ first repl-env get EVAL ] "eval" repl-env get data>> set-at +command-line get "*ARGV*" repl-env get data>> set-at + +"(def! not (fn* (a) (if a false true)))" rep drop +"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop +"(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop +"(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop + +MAIN: run-or-repl diff --git a/factor/src/types/types.factor b/factor/src/types/types.factor index b07a2456..ece5fff5 100644 --- a/factor/src/types/types.factor +++ b/factor/src/types/types.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2015 Jordan Lewis. ! See http://factorcode.org/license.txt for BSD license. -USING: regexp strings kernel sequences math.parser accessors malenv ; +USING: regexp strings kernel sequences math.parser accessors malenv assocs ; IN: types TUPLE: malsymbol { name string read-only } ; @@ -12,9 +12,14 @@ C: malsymbol TUPLE: fn { env malenv read-only } { binds sequence read-only } { exprs read-only } - { is-macro boolean } ; + { is-macro boolean } + { meta assoc } ; C: () fn : ( env binds exprs -- fn ) - f () ; + f f () ; + +TUPLE: malatom { val } ; + +C: malatom