unmaintained/lisp/lisp.factor

   1
   2 USING: kernel words namespaces combinators math
   3        quotations strings arrays hashtables sequences
   4        namespaces.lib rewrite-closures ;
   5
   6 IN: lisp
   7
   8 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   9
  10 : && ( obj seq -- ? ) [ call ] with all? ;
  11
  12 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13
  14 ! (quote sym)
  15
  16 SYMBOL: quote
  17
  18 : quote-exp? ( exp -- ? ) { [ array? ] [ length 2 = ] [ first quote = ] } && ;
  19
  20 : eval-quote ( exp -- val ) second ;
  21
  22 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23
  24 : eval-symbol ( exp -- val ) get ;
  25
  26 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  27
  28 DEFER: eval
  29
  30 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  31
  32 ! (begin ...)
  33
  34 SYMBOL: begin
  35
  36 : begin-exp? ( exp -- ? ) { [ array? ] [ length 2 >= ] [ first begin = ] } && ;
  37
  38 : eval-begin ( exp -- val ) 1 tail dup peek >r 1 head* [ eval ] each r> eval ;
  39
  40 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41
  42 ! (omega parameters ...)
  43
  44 SYMBOL: omega
  45
  46 : omega-exp? ( exp -- ? ) { [ array? ] [ length 3 >= ] [ first omega = ] } && ;
  47
  48 : eval-omega ( exp -- val )
  49 dup second swap 2 tail { begin } swap append [ eval ] curry lambda ;
  50
  51 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52
  53 ! (let ((var val) ...) exp ...)
  54
  55 SYMBOL: let
  56
  57 : let-exp? ( exp -- ? ) { [ array? ] [ length 2 >= ] [ first let = ] } && ;
  58
  59 : eval-let ( exp -- val )
  60 dup >r second [ second ] map r>
  61 dup 2 tail swap second [ first ] map add* omega add* add* eval ;
  62
  63 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  64
  65 ! (df name (param ...) exp ...)
  66
  67 SYMBOL: df
  68
  69 : df-exp? ( exp -- ? ) { [ array? ] [ length 3 >= ] [ first df = ] } && ;
  70
  71 : eval-df ( exp -- val ) dup 2 tail omega add* eval swap second tuck set ;
  72
  73 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  74
  75 ! (dv var val)
  76
  77 SYMBOL: dv
  78
  79 : dv-exp? ( exp -- ? ) { [ array? ] [ length 3 = ] [ first dv = ] } && ;
  80
  81 : eval-dv ( exp -- val ) dup >r third eval r> second set ;
  82
  83 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84
  85 ! (set! var val)
  86
  87 SYMBOL: set!
  88
  89 : set!-exp? ( exp -- ? ) { [ array? ] [ length 3 = ] [ first set! = ] } && ;
  90
  91 : eval-set! ( exp -- val ) dup >r third eval r> second set* ;
  92
  93 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  94
  95 ! (dyn (param ...) exp ...)
  96
  97 SYMBOL: dyn
  98
  99 : dyn-exp? ( exp -- ? ) { [ array? ] [ length 3 >= ] [ first dyn = ] } && ;
 100
 101 : eval-dyn ( exp -- val )
 102 dup second swap 2 tail begin add* [ eval ] curry parametric-quot scoped-quot ;
 103
 104 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 105
 106 ! (dy name (param ...) exp ...)
 107
 108 SYMBOL: dy
 109
 110 : dy-exp? ( exp -- ? ) { [ array? ] [ length 3 >= ] [ first dy = ] } && ;
 111
 112 : eval-dy ( exp -- val ) dup 2 tail dyn add* eval swap second tuck set ;
 113
 114 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 115
 116 ! : eval-list ( exp -- val )
 117 ! [ eval ] map unclip >r [ ] each r>
 118 ! { { [ dup quotation? ] [ call ] }
 119 !   { [ dup word? ]      [ execute ] } }
 120 ! cond ;
 121
 122 : eval-list ( exp -- val )
 123 unclip eval >r [ eval ] each r>
 124 { { [ dup quotation? ] [ call ] }
 125   { [ dup word? ]      [ execute ] } }
 126 cond ;
 127
 128 ! should probably be:
 129
 130 ! : eval-list ( exp -- val )
 131 ! unclip >r [ eval ] each r> eval
 132 ! { { [ dup quotation? ] [ call ] }
 133 !   { [ dup word? ]      [ execute ] } }
 134 ! cond ;
 135
 136 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 137
 138 : eval ( exp -- val )
 139 { { [ dup t eq? ]   [ ] }
 140   { [ dup f eq? ]   [ ] }
 141   { [ dup number? ] [ ] }
 142   { [ dup string? ] [ ] }
 143   { [ dup quotation? ] [ ] }
 144   { [ dup hashtable? ] [ ] }
 145   { [ dup quote-exp? ] [ eval-quote ] }
 146   { [ dup begin-exp? ] [ eval-begin ] }
 147   { [ dup omega-exp? ] [ eval-omega ] }
 148   { [ dup let-exp? ]   [ eval-let ] }
 149   { [ dup df-exp? ]    [ eval-df ] }
 150   { [ dup dv-exp? ]    [ eval-dv ] }
 151   { [ dup set!-exp? ]  [ eval-set! ] }
 152   { [ dup dyn-exp? ]   [ eval-dyn ] }
 153   { [ dup dy-exp? ]   [ eval-dy ] }
 154   { [ dup symbol? ] [ eval-symbol ] }
 155   { [ dup word? ] [ ] }
 156   { [ dup array? ]  [ eval-list ] }
 157 } cond ;
 158
 159 ! : eval-quot-call ( exp -- val ) [ eval ] map unclip >r [ ] each r> call ;
 160
 161 ! : eval-word-call ( exp -- val ) [ eval ] map unclip >r [ ] each r> execute ;
 162
 163 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 164