factor/stepA_mal/stepA_mal.factor

   1 ! Copyright (C) 2015 Jordan Lewis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit command-line continuations fry
   5 grouping hashtables io kernel lists locals lib.core lib.env
   6 lib.printer lib.reader lib.types math namespaces quotations
   7 readline sequences splitting strings ;
   8 IN: stepA_mal
   9
  10 SYMBOL: repl-env
  11
  12 DEFER: EVAL
  13
  14 : eval-ast ( ast env -- ast )
  15     {
  16         { [ over malsymbol? ] [ env-get ] }
  17         { [ over sequence? ]  [ '[ _ EVAL ] map ] }
  18         { [ over assoc? ]     [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
  19         [ drop ]
  20     } cond ;
  21
  22 :: eval-def! ( key value env -- maltype )
  23     value env EVAL [ key env env-set ] keep ;
  24
  25 :: eval-defmacro! ( key value env -- maltype )
  26     value env EVAL t >>macro? [ key env env-set ] keep ;
  27
  28 : eval-let* ( bindings body env -- maltype env )
  29     [ swap 2 group ] [ new-env ] bi* [
  30         dup '[ first2 _ EVAL swap _ env-set ] each
  31     ] keep ;
  32
  33 :: eval-do ( exprs env -- lastform env/f )
  34     exprs [
  35         { } f
  36     ] [
  37         unclip-last [ env eval-ast drop ] dip env
  38     ] if-empty ;
  39
  40 :: eval-if ( params env -- maltype env/f )
  41     params first env EVAL { f +nil+ } index not [
  42         params second env
  43     ] [
  44         params length 2 > [ params third env ] [ nil f ] if
  45     ] if ;
  46
  47 :: eval-fn* ( params env -- maltype )
  48     env params first [ name>> ] map params second <malfn> ;
  49
  50 :: eval-try* ( params env -- maltype )
  51     [ params first env EVAL ]
  52     [
  53         params length 1 > [
  54             params second second env new-env [ env-set ] keep
  55             params second third swap EVAL
  56         ] [
  57             throw
  58         ] if
  59     ] recover ;
  60
  61 : args-split ( bindlist -- bindlist restbinding/f )
  62     { "&" } split1 ?first ;
  63
  64 : make-bindings ( args bindlist restbinding/f -- bindingshash )
  65     swapd [ over length cut [ zip ] dip ] dip
  66     [ swap 2array suffix ] [ drop ] if* >hashtable ;
  67
  68 GENERIC: apply ( args fn -- maltype newenv/f )
  69
  70 M: malfn apply
  71     [ exprs>> nip ]
  72     [ env>> nip ]
  73     [ binds>> args-split make-bindings ] 2tri <malenv> ;
  74
  75 M: callable apply call( x -- y ) f ;
  76
  77 : is-pair? ( maltype -- ? )
  78     { [ sequence? ] [ string? not ] [ empty? not ] } 1&& ;
  79
  80 : quasiquote ( maltype -- maltype )
  81     {
  82         { [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
  83         { [ "unquote" over first symeq? ] [ second ] }
  84         { [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
  85           [ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
  86         [ "cons" <malsymbol> swap unclip swap [ quasiquote ] bi@ 3array ]
  87     } cond ;
  88
  89 :: macro-expand ( maltype env -- maltype )
  90     maltype dup array? [
  91         dup first { [ malsymbol? ] [ env env-find drop ] } 1&& [
  92             dup { [ malfn? ] [ macro?>> ] } 1&& [
  93                 [ rest ] dip apply [ EVAL ] keep macro-expand
  94             ] [ drop ] if
  95         ] when*
  96     ] when ;
  97
  98 : READ ( str -- maltype ) read-str ;
  99
 100 : EVAL ( maltype env -- maltype )
 101     over { [ array? ] [ empty? not ] } 1&& [
 102         [ macro-expand ] keep over array? [
 103             over first dup malsymbol? [ name>> ] when {
 104                 { "def!" [ [ rest first2 ] dip eval-def! f ] }
 105                 { "defmacro!" [ [ rest first2 ] dip eval-defmacro! f ] }
 106                 { "let*" [ [ rest first2 ] dip eval-let* ] }
 107                 { "do" [ [ rest ] dip eval-do ] }
 108                 { "if" [ [ rest ] dip eval-if ] }
 109                 { "fn*" [ [ rest ] dip eval-fn* f ] }
 110                 { "quote" [ drop second f ] }
 111                 { "quasiquote" [ [ second quasiquote ] dip ] }
 112                 { "macroexpand" [ [ second ] dip macro-expand f ] }
 113                 { "try*" [ [ rest ] dip eval-try* f ] }
 114                 [ drop '[ _ EVAL ] map unclip apply ]
 115             } case [ EVAL ] when*
 116         ] [
 117             eval-ast
 118         ] if
 119     ] [
 120         eval-ast
 121     ] if ;
 122
 123 [ apply [ EVAL ] when* ] mal-apply set-global
 124
 125 : PRINT ( maltype -- str ) pr-str ;
 126
 127 : REP ( str -- str )
 128     [
 129         READ repl-env get EVAL PRINT
 130     ] [
 131         nip pr-str "Error: " swap append
 132     ] recover ;
 133
 134 : REPL ( -- )
 135     "(println (str \"Mal [\" *host-language* \"]\"))" REP drop
 136     [
 137         "user> " readline [
 138             [ REP print flush ] unless-empty
 139         ] keep
 140     ] loop ;
 141
 142 : main ( -- )
 143     command-line get
 144     [ REPL ]
 145     [ first "(load-file \"" "\")" surround REP drop ]
 146     if-empty ;
 147
 148 f ns clone
 149 [ first repl-env get EVAL ] "eval" pick set-at
 150 command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at
 151 <malenv> repl-env set-global
 152
 153 "
 154 (def! *host-language* \"factor\")
 155 (def! not (fn* (a) (if a false true)))
 156 (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))
 157 (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)))))))
 158 " string-lines harvest [ READ repl-env get EVAL drop ] each
 159
 160 MAIN: main