gst/core.st

   1 FileStream fileIn: 'types.st'.
   2 FileStream fileIn: 'printer.st'.
   3 FileStream fileIn: 'reader.st'.
   4
   5 Object subclass: Core [
   6     Ns := Dictionary new.
   7     Core class >> Ns [ ^Ns ]
   8
   9     Core class >> coerce: block [
  10         block value ifTrue: [ ^MALObject True ] ifFalse: [ ^MALObject False ]
  11     ]
  12
  13     Core class >> nilable: args else: block [
  14         args first type = #nil ifTrue: [
  15             ^MALObject Nil
  16         ] ifFalse: [
  17             ^block value
  18         ]
  19     ]
  20
  21     Core class >> printedArgs: args readable: readable sep: sep [
  22         | items |
  23         items := args collect:
  24             [ :arg | Printer prStr: arg printReadably: readable ].
  25         "NOTE: {} join returns the unchanged array"
  26         items isEmpty ifTrue: [ ^'' ] ifFalse: [ ^items join: sep ]
  27     ]
  28 ]
  29
  30 Core Ns at: #+ put:
  31     (Fn new: [ :args | MALNumber new: args first value + args second value ]).
  32 Core Ns at: #- put:
  33     (Fn new: [ :args | MALNumber new: args first value - args second value ]).
  34 Core Ns at: #* put:
  35     (Fn new: [ :args | MALNumber new: args first value * args second value ]).
  36 Core Ns at: #/ put:
  37     (Fn new: [ :args | MALNumber new: args first value // args second value ]).
  38
  39 Core Ns at: #'pr-str' put:
  40     (Fn new: [ :args | MALString new: (Core printedArgs: args readable: true
  41                                             sep: ' ') ]).
  42 Core Ns at: #str put:
  43     (Fn new: [ :args | MALString new: (Core printedArgs: args readable: false
  44                                            sep: '') ]).
  45 Core Ns at: #prn put:
  46     (Fn new: [ :args |
  47         (Core printedArgs: args readable: true sep: ' ') displayNl.
  48         MALObject Nil ]).
  49 Core Ns at: #println put:
  50     (Fn new: [ :args |
  51         (Core printedArgs: args readable: false sep: ' ') displayNl.
  52         MALObject Nil ]).
  53
  54 Core Ns at: #list put:
  55     (Fn new: [ :args | MALList new: (OrderedCollection from: args) ]).
  56 Core Ns at: #'list?' put:
  57     (Fn new: [ :args | Core coerce: [ args first type = #list ] ]).
  58 Core Ns at: #'empty?' put:
  59     (Fn new: [ :args | Core coerce: [ args first value isEmpty ] ]).
  60 Core Ns at: #count put:
  61     (Fn new: [ :args | MALNumber new: args first value size ]).
  62
  63 Core Ns at: #= put:
  64     (Fn new: [ :args | Core coerce: [ args first = args second ] ]).
  65
  66 Core Ns at: #< put:
  67     (Fn new: [ :args | Core coerce: [ args first value < args second value ] ]).
  68 Core Ns at: #<= put:
  69     (Fn new: [ :args | Core coerce: [ args first value <= args second value ] ]).
  70 Core Ns at: #> put:
  71     (Fn new: [ :args | Core coerce: [ args first value > args second value ] ]).
  72 Core Ns at: #>= put:
  73     (Fn new: [ :args | Core coerce: [ args first value >= args second value ] ]).
  74
  75 Core Ns at: #'read-string' put:
  76     (Fn new: [ :args | Reader readStr: args first value ]).
  77 Core Ns at: #slurp put:
  78     (Fn new: [ :args | MALString new: (File path: args first value) contents ]).
  79 Core Ns at: #throw put:
  80     (Fn new: [ :args | MALCustomError new signal: args first ]).
  81
  82 Core Ns at: #atom put:
  83     (Fn new: [ :args | MALAtom new: args first ]).
  84 Core Ns at: #'atom?' put:
  85     (Fn new: [ :args | Core coerce: [ args first type = #atom ] ]).
  86 Core Ns at: #deref put:
  87     (Fn new: [ :args | args first value ]).
  88 Core Ns at: #'reset!' put:
  89     (Fn new: [ :args | args first value: args second. args second ]).
  90 Core Ns at: #'swap!' put:
  91     (Fn new: [ :args |
  92         | a f x xs result |
  93         a := args first.
  94         f := args second fn.
  95         x := a value.
  96         xs := args allButFirst: 2.
  97         result := f value: (xs copyWithFirst: x).
  98         a value: result.
  99         result ]).
 100
 101 Core Ns at: #cons put:
 102     (Fn new: [ :args | MALList new: (args second value copyWithFirst: args first) ]).
 103 Core Ns at: #concat put:
 104     (Fn new: [ :args | MALList new: (OrderedCollection join:
 105         (args collect: [ :arg | arg value ])) ]).
 106 Core Ns at: #nth put:
 107     (Fn new: [ :args |
 108         | items index |
 109         items := args first value.
 110         index := args second value + 1.
 111         items at: index ifAbsent: [ MALOutOfBounds new signal ] ]).
 112 Core Ns at: #first put:
 113     (Fn new: [ :args | Core nilable: args else: [
 114         args first value at: 1 ifAbsent: [ MALObject Nil ] ] ]).
 115 Core Ns at: #rest put:
 116     (Fn new: [ :args |
 117         | items rest |
 118         items := args first value.
 119         (args first type = #nil or: [ items isEmpty  ]) ifTrue: [
 120             rest := {}
 121         ] ifFalse: [
 122             rest := items allButFirst
 123         ].
 124         MALList new: (OrderedCollection from: rest) ]).
 125
 126 Core Ns at: #apply put:
 127     (Fn new: [ :args |
 128         | f rest result |
 129         f := args first fn.
 130         args size < 3 ifTrue: [
 131             rest := {}
 132         ] ifFalse: [
 133             rest := args copyFrom: 2 to: args size - 1
 134         ].
 135         rest := rest, args last value.
 136         f value: rest ]).
 137 Core Ns at: #map put:
 138     (Fn new: [ :args |
 139         | items f result |
 140         f := args first fn.
 141         items := args second value.
 142         result := items collect: [ :item | f value: {item} ].
 143         MALList new: (OrderedCollection from: result) ]).
 144
 145 Core Ns at: #'nil?' put:
 146     (Fn new: [ :args | Core coerce: [ args first type = #nil ] ]).
 147 Core Ns at: #'true?' put:
 148     (Fn new: [ :args | Core coerce: [ args first type = #true ] ]).
 149 Core Ns at: #'false?' put:
 150     (Fn new: [ :args | Core coerce: [ args first type = #false ] ]).
 151 Core Ns at: #'symbol?' put:
 152     (Fn new: [ :args | Core coerce: [ args first type = #symbol ] ]).
 153 Core Ns at: #'keyword?' put:
 154     (Fn new: [ :args | Core coerce: [ args first type = #keyword ] ]).
 155 Core Ns at: #'vector?' put:
 156     (Fn new: [ :args | Core coerce: [ args first type = #vector ] ]).
 157 Core Ns at: #'map?' put:
 158     (Fn new: [ :args | Core coerce: [ args first type = #map ] ]).
 159 Core Ns at: #'sequential?' put:
 160     (Fn new: [ :args | Core coerce: [ args first type = #list or:
 161                                      [ args first type = #vector ] ] ]).
 162
 163 Core Ns at: #symbol put:
 164     (Fn new: [ :args | MALSymbol new: args first value asSymbol ]).
 165 Core Ns at: #keyword put:
 166     (Fn new: [ :args | MALKeyword new: args first value asSymbol ]).
 167 Core Ns at: #vector put:
 168     (Fn new: [ :args | MALVector new: (OrderedCollection from: args) ]).
 169 Core Ns at: #'hash-map' put:
 170     (Fn new: [ :args | MALMap new: args asDictionary ]).
 171
 172 Core Ns at: #assoc put:
 173     (Fn new: [ :args |
 174         | result keyVals |
 175         result := Dictionary from: args first value associations.
 176         keyVals := args allButFirst.
 177         1 to: keyVals size by: 2 do:
 178             [ :i | result add: (keyVals at: i) -> (keyVals at: i + 1) ].
 179         MALMap new: result ]).
 180 Core Ns at: #dissoc put:
 181     (Fn new: [ :args |
 182         | result keys |
 183         result := Dictionary from: args first value associations.
 184         keys := args allButFirst.
 185         keys do: [ :key | result removeKey: key ifAbsent: [ nil ] ].
 186         MALMap new: result ]).
 187 Core Ns at: #get put:
 188     (Fn new: [ :args | Core nilable: args else:
 189         [ args first value at: args second ifAbsent: [ MALObject Nil ] ] ]).
 190 Core Ns at: #'contains?' put:
 191     (Fn new: [ :args | Core coerce: [ args first value includesKey: args second ] ]).
 192 Core Ns at: #keys put:
 193     (Fn new: [ :args | MALList new: (OrderedCollection from: args first value keys) ]).
 194 Core Ns at: #vals put:
 195     (Fn new: [ :args | MALList new: (OrderedCollection from: args first value values) ]).