forth/core.fs

   1 require env.fs
   2
   3 0 MalEnv. constant core
   4
   5 : args-as-native { argv argc -- entry*argc... }
   6     argc 0 ?do
   7         argv i cells + @ as-native
   8     loop ;
   9
  10 : defcore* ( sym xt )
  11     MalNativeFn. core env/set ;
  12
  13 : defcore
  14     parse-allot-name MalSymbol. ( xt )
  15     ['] defcore* :noname ;
  16
  17 defcore +  args-as-native +  MalInt. ;;
  18 defcore -  args-as-native -  MalInt. ;;
  19 defcore *  args-as-native *  MalInt. ;;
  20 defcore /  args-as-native /  MalInt. ;;
  21 defcore <  args-as-native <  mal-bool ;;
  22 defcore >  args-as-native >  mal-bool ;;
  23 defcore <= args-as-native <= mal-bool ;;
  24 defcore >= args-as-native >= mal-bool ;;
  25
  26 defcore list { argv argc }
  27     argc cells allocate throw { start }
  28     argv  start  argc cells  cmove
  29     start argc MalList. ;;
  30
  31 defcore vector { argv argc }
  32     argc cells allocate throw { start }
  33     argv  start  argc cells  cmove
  34     start argc MalList.
  35     MalVector new swap over MalVector/list ! ;;
  36
  37 defcore empty? drop @ empty? ;;
  38 defcore count drop @ mal-count ;;
  39
  40 defcore = drop dup @ swap cell+ @ swap m= mal-bool ;;
  41
  42 : pr-str-multi ( readably? argv argc )
  43     ?dup 0= if drop 0 0
  44     else
  45         { argv argc }
  46         new-str
  47         argv @ pr-buf
  48         argc 1 ?do
  49             a-space
  50             argv i cells + @ pr-buf
  51         loop
  52     endif ;
  53
  54 defcore prn true -rot pr-str-multi type cr drop mal-nil ;;
  55 defcore pr-str true -rot pr-str-multi MalString. nip ;;
  56 defcore println false -rot pr-str-multi type cr drop mal-nil ;;
  57 defcore str ( argv argc )
  58     dup 0= if
  59         MalString.
  60     else
  61         { argv argc }
  62         false new-str
  63         argc 0 ?do
  64             argv i cells + @ pr-buf
  65         loop
  66         MalString. nip
  67     endif ;;
  68
  69 defcore read-string drop @ unpack-str read-str ;;
  70 defcore slurp drop @ unpack-str slurp-file MalString. ;;
  71
  72 create core-buff 128 allot
  73 defcore readline ( argv argc -- mal-string )
  74     drop @ unpack-str type stdout flush-file drop
  75     core-buff 128 stdin read-line throw
  76     if core-buff swap MalString. else drop mal-nil endif ;;
  77
  78
  79 defcore cons ( argv[item,coll] argc )
  80     drop dup @ swap cell+ @ ( item coll )
  81     to-list conj ;;
  82
  83 defcore concat { lists argc }
  84     MalList new
  85     lists over MalList/start !
  86     argc over MalList/count !
  87     MalList/concat ;;
  88
  89 defcore conj { argv argc }
  90     argv @ ( coll )
  91     argc 1 ?do
  92         argv i cells + @ swap conj
  93     loop ;;
  94
  95 defcore seq drop @ seq ;;
  96
  97 defcore assoc { argv argc }
  98     argv @ ( coll )
  99     argv argc cells +  argv cell+  +do
 100         i @ \ key
 101         i cell+ @ \ val
 102         rot assoc
 103     2 cells +loop ;;
 104
 105 defcore keys ( argv argc )
 106     drop @ MalMap/list @
 107     dup MalList/start @ swap MalList/count @ { start count }
 108     here
 109     start count cells +  start  +do
 110         i @ ,
 111     2 cells +loop
 112     here>MalList ;;
 113
 114 defcore vals ( argv argc )
 115     drop @ MalMap/list @
 116     dup MalList/start @ swap MalList/count @ { start count }
 117     here
 118     start count cells +  start cell+  +do
 119         i @ ,
 120     2 cells +loop
 121     here>MalList ;;
 122
 123 defcore dissoc { argv argc }
 124     argv @ \ coll
 125     argv argc cells +  argv cell+  +do
 126         i @ swap dissoc
 127     cell +loop ;;
 128
 129 defcore hash-map { argv argc }
 130     MalMap/Empty
 131     argc cells argv +  argv  +do
 132         i @  i cell+ @  rot  assoc
 133     2 cells +loop ;;
 134
 135 defcore get { argv argc }
 136     argc 3 < if mal-nil else argv cell+ cell+ @ endif
 137     argv cell+ @ \ key
 138     argv @ \ coll
 139     get ;;
 140
 141 defcore contains? { argv argc }
 142     0
 143     argv cell+ @ \ key
 144     argv @ \ coll
 145     get 0 <> mal-bool ;;
 146
 147 defcore nth ( argv[coll,i] argc )
 148     drop dup @ to-list ( argv list )
 149     swap cell+ @ MalInt/int @ ( list i )
 150     over MalList/count @ ( list i count )
 151     2dup >= if { i count }
 152         0 0
 153         new-str i int>str str-append s\" \040>= " count int>str
 154         s" nth out of bounds: " ...throw-str
 155     endif drop ( list i )
 156     cells swap ( c-offset list )
 157     MalList/start @ + @ ;;
 158
 159 defcore first ( argv[coll] argc )
 160     drop @ to-list
 161     dup MalList/count @ 0= if
 162         drop mal-nil
 163     else
 164         MalList/start @ @
 165     endif ;;
 166
 167 defcore rest ( argv[coll] argc )
 168     drop @ to-list MalList/rest ;;
 169
 170 defcore meta ( argv[obj] argc )
 171     drop @ mal-meta @
 172     ?dup 0= if mal-nil endif ;;
 173
 174 defcore with-meta ( argv[obj,meta] argc )
 175     drop ( argv )
 176     dup cell+ @  swap @  ( meta obj )
 177     dup mal-type @ MalTypeType-struct @ ( meta obj obj-size )
 178     dup allocate throw { new-obj } ( meta obj obj-size )
 179     new-obj swap cmove ( meta )
 180     new-obj mal-meta ! ( )
 181     new-obj ;;
 182
 183 defcore atom ( argv[val] argc )
 184     drop @ Atom. ;;
 185
 186 defcore deref ( argv[atom] argc )
 187     drop @ Atom/val @ ;;
 188
 189 defcore reset! ( argv[atom,val] argc )
 190     drop dup cell+ @ ( argv val )
 191     dup -rot swap @ Atom/val ! ;;
 192
 193 defcore apply { argv argc -- val }
 194     \ argv is (fn args... more-args)
 195     argv argc 1- cells + @ to-list { more-args }
 196     argc 2 - { list0len }
 197     more-args MalList/count @ list0len + { final-argc }
 198     final-argc cells allocate throw { final-argv }
 199     argv cell+   final-argv   list0len cells   cmove
 200     more-args MalList/start @   final-argv list0len cells +  final-argc list0len - cells  cmove
 201     final-argv final-argc argv @  invoke ;;
 202
 203 defcore throw ( argv argc -- )
 204     drop @ to exception-object
 205     1 throw ;;
 206
 207 defcore map?     drop @ mal-type @ MalMap     = mal-bool ;;
 208 defcore list?    drop @ mal-type @ MalList    = mal-bool ;;
 209 defcore vector?  drop @ mal-type @ MalVector  = mal-bool ;;
 210 defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;;
 211 defcore symbol?  drop @ mal-type @ MalSymbol  = mal-bool ;;
 212 defcore string?  drop @ mal-type @ MalString  = mal-bool ;;
 213 defcore atom?    drop @ mal-type @ Atom       = mal-bool ;;
 214 defcore true?    drop @ mal-true  = mal-bool ;;
 215 defcore false?   drop @ mal-false = mal-bool ;;
 216 defcore nil?     drop @ mal-nil   = mal-bool ;;
 217 defcore number?  drop @ mal-type @ MalInt = mal-bool ;;
 218 defcore fn?
 219     drop @
 220     dup mal-type @ MalUserFn = if
 221         MalUserFn/is-macro? @ if
 222             mal-false
 223         else
 224             mal-true
 225         endif
 226     else
 227         mal-type @ MalNativeFn = if
 228             mal-true
 229         else
 230             mal-false
 231         endif
 232     endif ;;
 233 defcore macro?   drop @ dup mal-type @ MalUserFn =
 234                         swap MalUserFn/is-macro? @
 235                         and mal-bool ;;
 236
 237 defcore sequential? drop @ sequential? ;;
 238
 239 defcore keyword  drop @ unpack-str MalKeyword. ;;
 240 defcore symbol   drop @ unpack-str MalSymbol. ;;
 241
 242 defcore time-ms 2drop utime d>s 1000 / MalInt. ;;