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