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