impls/factor/step7_quote/step7_quote.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 ;
   8 IN: step7_quote
   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-let* ( bindings body env -- maltype env )
  26     [ swap 2 group ] [ new-env ] bi* [
  27         dup '[ first2 _ EVAL swap _ env-set ] each
  28     ] keep ;
  29
  30 :: eval-do ( exprs env -- lastform env/f )
  31     exprs [
  32         { } f
  33     ] [
  34         unclip-last [ env eval-ast drop ] dip env
  35     ] if-empty ;
  36
  37 :: eval-if ( params env -- maltype env/f )
  38     params first env EVAL { f +nil+ } index not [
  39         params second env
  40     ] [
  41         params length 2 > [ params third env ] [ nil f ] if
  42     ] if ;
  43
  44 :: eval-fn* ( params env -- maltype )
  45     env params first [ name>> ] map params second <malfn> ;
  46
  47 : args-split ( bindlist -- bindlist restbinding/f )
  48     { "&" } split1 ?first ;
  49
  50 : make-bindings ( args bindlist restbinding/f -- bindingshash )
  51     swapd [ over length cut [ zip ] dip ] dip
  52     [ swap 2array suffix ] [ drop ] if* >hashtable ;
  53
  54 GENERIC: apply ( args fn -- maltype newenv/f )
  55
  56 M: malfn apply
  57     [ exprs>> nip ]
  58     [ env>> nip ]
  59     [ binds>> args-split make-bindings ] 2tri <malenv> ;
  60
  61 M: callable apply call( x -- y ) f ;
  62
  63 : is-pair? ( maltype -- bool )
  64     { [ sequence? ] [ empty? not ] } 1&& ;
  65
  66 : quasiquote ( maltype -- maltype )
  67     {
  68         { [ dup is-pair? not ] [ [ "quote" <malsymbol> ] dip 2array ] }
  69         { [ "unquote" over first symeq? ] [ second ] }
  70         { [ dup first { [ is-pair? ] [ first "splice-unquote" swap symeq? ] } 1&& ]
  71           [ [ "concat" <malsymbol> ] dip unclip second swap quasiquote 3array ] }
  72         [ "cons" <malsymbol> swap unclip quasiquote swap quasiquote 3array ]
  73     } cond ;
  74
  75 : READ ( str -- maltype ) read-str ;
  76
  77 : EVAL ( maltype env -- maltype )
  78     over { [ array? ] [ empty? not ] } 1&& [
  79         over first dup malsymbol? [ name>> ] when {
  80             { "def!" [ [ rest first2 ] dip eval-def! f ] }
  81             { "let*" [ [ first2 ] dip eval-let* ] }
  82             { "do" [ [ rest ] dip eval-do ] }
  83             { "if" [ [ rest ] dip eval-if ] }
  84             { "fn*" [ [ rest ] dip eval-fn* f ] }
  85             { "quote" [ drop second f ] }
  86             { "quasiquote" [ [ second quasiquote ] dip ] }
  87             [ drop '[ _ EVAL ] map unclip apply ]
  88         } case [ EVAL ] when*
  89     ] [
  90         eval-ast
  91     ] if ;
  92
  93 [ apply [ EVAL ] when* ] mal-apply set-global
  94
  95 : PRINT ( maltype -- str ) pr-str ;
  96
  97 : REP ( str -- str )
  98     [
  99         READ repl-env get EVAL PRINT
 100     ] [
 101         nip pr-str "Error: " swap append
 102     ] recover ;
 103
 104 : REPL ( -- )
 105     [
 106         "user> " readline [
 107             [ REP print flush ] unless-empty
 108         ] keep
 109     ] loop ;
 110
 111 : main ( -- )
 112     command-line get
 113     [ REPL ]
 114     [ first "(load-file \"" "\")" surround REP drop ]
 115     if-empty ;
 116
 117 f ns clone
 118 [ first repl-env get EVAL ] "eval" pick set-at
 119 command-line get dup empty? [ rest ] unless "*ARGV*" pick set-at
 120 <malenv> repl-env set-global
 121
 122 "
 123 (def! not (fn* (a) (if a false true)))
 124 (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\\nnil)\")))))
 125 " string-lines harvest [ REP drop ] each
 126
 127 MAIN: main