factor/step3_env/step3_env.factor

   1 ! Copyright (C) 2015 Jordan Lewis.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators combinators.short-circuit
   4 continuations fry grouping hashtables io kernel locals lib.env lib.printer
   5 lib.reader lib.types math namespaces quotations readline sequences ;
   6 IN: step3_env
   7
   8 CONSTANT: repl-bindings H{
   9     { "+" [ + ] }
  10     { "-" [ - ] }
  11     { "*" [ * ] }
  12     { "/" [ / ] }
  13 }
  14
  15 SYMBOL: repl-env
  16
  17 DEFER: EVAL
  18
  19 : eval-ast ( ast env -- ast )
  20     {
  21         { [ over malsymbol? ] [ env-get ] }
  22         { [ over sequence? ]  [ '[ _ EVAL ] map ] }
  23         { [ over assoc? ]     [ '[ [ _ EVAL ] bi@ ] assoc-map ] }
  24         [ drop ]
  25     } cond ;
  26
  27 :: eval-def! ( key value env -- maltype )
  28     value env EVAL [ key env env-set ] keep ;
  29
  30 : eval-let* ( bindings body env -- maltype )
  31     [ swap 2 group ] [ new-env ] bi* [
  32         dup '[ first2 _ EVAL swap _ env-set ] each
  33     ] keep EVAL ;
  34
  35 : READ ( str -- maltype ) read-str ;
  36
  37 :: EVAL ( maltype env -- maltype )
  38     maltype dup { [ array? ] [ empty? not ] } 1&& [
  39         unclip dup dup malsymbol? [ name>> ] when {
  40             { "def!" [ drop first2 env eval-def! ] }
  41             { "let*" [ drop first2 env eval-let* ] }
  42             [
  43                 drop env eval-ast dup quotation? [
  44                     [ env eval-ast ] dip with-datastack first
  45                 ] [
  46                     drop "not a fn" throw
  47                 ] if
  48             ]
  49         } case
  50     ] [
  51         env eval-ast
  52     ] if ;
  53
  54 : PRINT ( maltype -- str ) pr-str ;
  55
  56 : REP ( str -- str )
  57     [
  58         READ repl-env get EVAL PRINT
  59     ] [
  60         nip pr-str "Error: " swap append
  61     ] recover ;
  62
  63 : REPL ( -- )
  64     f repl-bindings <malenv> repl-env set
  65     [
  66         "user> " readline [
  67             [ REP print flush ] unless-empty
  68         ] keep
  69     ] loop ;
  70
  71 MAIN: REPL