rexx/core.rexx

   1 #ifndef __core__
   2 #define __core__
   3
   4 #include "types.rexx"
   5
   6 mal_equal?: procedure expose values. /* mal_equal?(a, b) */
   7   return new_boolean(equal?(arg(1), arg(2)))
   8
   9 mal_throw: procedure expose values. err /* mal_throw(a) */
  10   err = "__MAL_EXCEPTION__" arg(1)
  11   return "ERR"
  12
  13 mal_nil?: procedure expose values. /* mal_nil?(a) */
  14   return new_boolean(nil?(arg(1)))
  15
  16 mal_true?: procedure expose values. /* mal_true?(a) */
  17   return new_boolean(true?(arg(1)))
  18
  19 mal_false?: procedure expose values. /* mal_false?(a) */
  20   return new_boolean(false?(arg(1)))
  21
  22 mal_string?: procedure expose values. /* mal_string?(a) */
  23   return new_boolean(string?(arg(1)))
  24
  25 mal_symbol: procedure expose values. /* mal_symbol(a) */
  26   return new_symbol(obj_val(arg(1)))
  27
  28 mal_symbol?: procedure expose values. /* mal_symbol?(a) */
  29   return new_boolean(symbol?(arg(1)))
  30
  31 mal_keyword: procedure expose values. /* mal_keyword(a) */
  32   return new_keyword(obj_val(arg(1)))
  33
  34 mal_keyword?: procedure expose values. /* mal_keyword?(a) */
  35   return new_boolean(keyword?(arg(1)))
  36
  37 mal_number?: procedure expose values. /* mal_number?(a) */
  38   return new_boolean(number?(arg(1)))
  39
  40 mal_fn?: procedure expose values. /* mal_fn?(a) */
  41   return new_boolean(nativefn?(arg(1)) | (func?(arg(1)) & (func_is_macro(arg(1)) \= 1)))
  42
  43 mal_macro?: procedure expose values. /* mal_macro?(a) */
  44   return new_boolean(func_macro?(arg(1)))
  45
  46 mal_pr_str: procedure expose values. /* mal_pr_str(...) */
  47   res = ""
  48   do i=1 to arg()
  49     element = pr_str(arg(i), 1)
  50     if i == 1 then
  51       res = element
  52     else
  53       res = res || " " || element
  54   end
  55   return new_string(res)
  56
  57 mal_str: procedure expose values. /* mal_str(...) */
  58   res = ""
  59   do i=1 to arg()
  60     element = pr_str(arg(i), 0)
  61     if i == 1 then
  62       res = element
  63     else
  64       res = res || element
  65   end
  66   return new_string(res)
  67
  68 mal_prn: procedure expose values. /* mal_prn(...) */
  69   res = ""
  70   do i=1 to arg()
  71     element = pr_str(arg(i), 1)
  72     if i == 1 then
  73       res = element
  74     else
  75       res = res || " " || element
  76   end
  77   say res
  78   return new_nil()
  79
  80 mal_println: procedure expose values. /* mal_println(...) */
  81   res = ""
  82   do i=1 to arg()
  83     element = pr_str(arg(i), 0)
  84     if i == 1 then
  85       res = element
  86     else
  87       res = res || " " || element
  88   end
  89   say res
  90   return new_nil()
  91
  92 mal_read_string: procedure expose values. err /* mal_read_string(str) */
  93   return read_str(obj_val(arg(1)))
  94
  95 mal_readline: procedure expose values. /* mal_readline(prompt) */
  96   line = readline(obj_val(arg(1)))
  97   if length(line) > 0 then return new_string(line)
  98   if lines() > 0 then return new_string("")
  99   return new_nil()
 100
 101 mal_slurp: procedure expose values. /* mal_read_string(filename) */
 102   file_content = charin(obj_val(arg(1)), 1, 100000)
 103   return new_string(file_content)
 104
 105 mal_lt: procedure expose values. /* mal_lt(a, b) */
 106   return new_boolean(obj_val(arg(1)) < obj_val(arg(2)))
 107
 108 mal_lte: procedure expose values. /* mal_lte(a, b) */
 109   return new_boolean(obj_val(arg(1)) <= obj_val(arg(2)))
 110
 111 mal_gt: procedure expose values. /* mal_gt(a, b) */
 112   return new_boolean(obj_val(arg(1)) > obj_val(arg(2)))
 113
 114 mal_gte: procedure expose values. /* mal_gte(a, b) */
 115   return new_boolean(obj_val(arg(1)) >= obj_val(arg(2)))
 116
 117 mal_add: procedure expose values. /* mal_add(a, b) */
 118   return new_number(obj_val(arg(1)) + obj_val(arg(2)))
 119
 120 mal_sub: procedure expose values. /* mal_sub(a, b) */
 121   return new_number(obj_val(arg(1)) - obj_val(arg(2)))
 122
 123 mal_mul: procedure expose values. /* mal_mul(a, b) */
 124   return new_number(obj_val(arg(1)) * obj_val(arg(2)))
 125
 126 mal_div: procedure expose values. /* mal_div(a, b) */
 127   return new_number(obj_val(arg(1)) / obj_val(arg(2)))
 128
 129 mal_time_ms: procedure expose values. /* mal_time_ms() */
 130   return new_number(trunc(time('E') * 1000))
 131
 132 mal_list: procedure expose values. /* mal_list(...) */
 133   res = ""
 134   do i=1 to arg()
 135     if i == 1 then
 136       res = arg(i)
 137     else
 138       res = res || " " || arg(i)
 139   end
 140   return new_list(res)
 141
 142 mal_list?: procedure expose values. /* mal_list?(a) */
 143   return new_boolean(list?(arg(1)))
 144
 145 mal_vector: procedure expose values. /* mal_vector(...) */
 146   res = ""
 147   do i=1 to arg()
 148     if i == 1 then
 149       res = arg(i)
 150     else
 151       res = res || " " || arg(i)
 152   end
 153   return new_vector(res)
 154
 155 mal_vector?: procedure expose values. /* mal_vector?(a) */
 156   return new_boolean(vector?(arg(1)))
 157
 158 mal_hash_map: procedure expose values. /* mal_hash_map(...) */
 159   res = ""
 160   do i=1 to arg()
 161     if i == 1 then
 162       res = arg(i)
 163     else
 164       res = res || " " || arg(i)
 165   end
 166   return new_hashmap(res)
 167
 168 mal_map?: procedure expose values. /* mal_map?(a) */
 169   return new_boolean(hashmap?(arg(1)))
 170
 171 mal_assoc: procedure expose values. /* mal_assoc(a, ...) */
 172   hm = arg(1)
 173   res = ""
 174   do i=2 to arg() by 2
 175     key_val = arg(i) || " " || arg(i + 1)
 176     if res == 2 then
 177       res = key_val
 178     else
 179       res = res || " " || key_val
 180   end
 181   hm_val = obj_val(hm)
 182   do i=1 to words(hm_val) by 2
 183     if \contains?(res, word(hm_val, i)) then
 184       res = res || " " || word(hm_val, i) || " " || word(hm_val, i + 1)
 185   end
 186   return new_hashmap(res)
 187
 188 mal_dissoc: procedure expose values. /* mal_dissoc(a, ...) */
 189   hm = arg(1)
 190   res = ""
 191   hm_val = obj_val(hm)
 192   do i=1 to words(hm_val) by 2
 193     key = word(hm_val, i)
 194     found = 0
 195     do j=2 to arg()
 196       if equal?(key, arg(j)) then do
 197         found = 1
 198         leave
 199       end
 200     end
 201     if \found then do
 202       if length(res) > 0 then res = res || " "
 203       res = res || key || " " || word(hm_val, i + 1)
 204     end
 205   end
 206   return new_hashmap(res)
 207
 208 mal_get: procedure expose values. /* mal_get(a, b) */
 209   res = hashmap_get(obj_val(arg(1)), arg(2))
 210   if res == "" then
 211     return new_nil()
 212   else
 213     return res
 214
 215 mal_contains?: procedure expose values. /* mal_contains?(a, b) */
 216   return new_boolean(contains?(obj_val(arg(1)), arg(2)))
 217
 218 mal_keys: procedure expose values. /* mal_keys(a) */
 219   hm_val = obj_val(arg(1))
 220   seq = ""
 221   do i=1 to words(hm_val) by 2
 222     if i == 1 then
 223       seq = word(hm_val, i)
 224     else
 225       seq = seq || " " || word(hm_val, i)
 226   end
 227   return new_list(seq)
 228
 229 mal_vals: procedure expose values. /* mal_vals(a) */
 230   hm_val = obj_val(arg(1))
 231   seq = ""
 232   do i=2 to words(hm_val) by 2
 233     if i == 1 then
 234       seq = word(hm_val, i)
 235     else
 236       seq = seq || " " || word(hm_val, i)
 237   end
 238   return new_list(seq)
 239
 240 mal_sequential?: procedure expose values. /* mal_sequential?(a) */
 241   return new_boolean(sequential?(arg(1)))
 242
 243 mal_cons: procedure expose values. /* mal_cons(a, b) */
 244   return new_list(arg(1) || " " || obj_val(arg(2)))
 245
 246 mal_concat: procedure expose values. /* mal_concat(...) */
 247   seq = ""
 248   do i=1 to arg()
 249     if i == 1 then
 250       seq = obj_val(arg(i))
 251     else
 252       seq = seq || " " || obj_val(arg(i))
 253   end
 254   return new_list(seq)
 255
 256 mal_nth: procedure expose values. err /* mal_nth(list, index) */
 257   list_val = obj_val(arg(1))
 258   i = obj_val(arg(2))
 259   if i >= words(list_val) then do
 260     err = "nth: index out of range"
 261     return "ERR"
 262   end
 263   return word(list_val, i + 1)
 264
 265 mal_first: procedure expose values. /* mal_first(a) */
 266   if nil?(arg(1)) then return new_nil()
 267   list_val = obj_val(arg(1))
 268   if words(list_val) == 0 then return new_nil()
 269   return word(list_val, 1)
 270
 271 mal_rest: procedure expose values. /* mal_rest(a) */
 272   return new_list(subword(obj_val(arg(1)), 2))
 273
 274 mal_empty?: procedure expose values. /* mal_empty?(a) */
 275   if nil?(arg(1)) then return new_true()
 276   return new_boolean(count_elements(arg(1)) == 0)
 277
 278 mal_count: procedure expose values. /* mal_count(a) */
 279   if nil?(arg(1)) then return new_number(0)
 280   return new_number(count_elements(arg(1)))
 281
 282 apply_function: procedure expose values. env. err /* apply_function(fn, lst) */
 283   f = arg(1)
 284   call_args = arg(2)
 285   select
 286     when nativefn?(f) then do
 287       call_args_val = obj_val(call_args)
 288       call_list = ""
 289       do i=1 to words(call_args_val)
 290         element = '"' || word(call_args_val, i) || '"'
 291         if i > 1 then
 292           call_list = call_list || ', ' || element
 293         else
 294           call_list = element
 295       end
 296       res = ""
 297       interpret "res = " || obj_val(f) || "(" || call_list || ")"
 298       return res
 299     end
 300     when func?(f) then do
 301       apply_env_idx = new_env(func_env_idx(f), func_binds(f), call_args)
 302       return eval(func_body_ast(f), apply_env_idx)
 303     end
 304     otherwise
 305       err = "Unsupported function object type: " || obj_type(f)
 306       return "ERR"
 307     end
 308
 309 mal_apply: procedure expose values. env. err /* mal_apply(fn, ..., lst) */
 310   fn = arg(1)
 311   seq = ""
 312   do i=2 to (arg() - 1)
 313     if i == 2 then
 314       seq = arg(i)
 315     else
 316       seq = seq || " " || arg(i)
 317   end
 318   if arg() > 1 then do
 319     seq = seq || " " || obj_val(arg(arg()))
 320   end
 321   return apply_function(fn, new_list(seq))
 322
 323 mal_map: procedure expose values. env. err /* mal_map(f, lst) */
 324   fn = arg(1)
 325   lst_val = obj_val(arg(2))
 326   res = ""
 327   do i=1 to words(lst_val)
 328     element = word(lst_val, i)
 329     mapped_element = apply_function(fn, new_list(element))
 330     if mapped_element == "ERR" then return "ERR"
 331     if i == 1 then
 332       res = mapped_element
 333     else
 334       res = res || " " || mapped_element
 335   end
 336   return new_list(res)
 337
 338 mal_conj: procedure expose values. env. err /* mal_conj(a, ...) */
 339   a = arg(1)
 340   select
 341     when list?(a) then do
 342       do i=2 to arg()
 343         a = mal_cons(arg(i), a)
 344       end
 345       return a
 346     end
 347     when vector?(a) then do
 348       seq = obj_val(a)
 349       do i=2 to arg()
 350         if length(seq) > 0 then seq = seq || " "
 351         seq = seq || arg(i)
 352       end
 353       return new_vector(seq)
 354     end
 355     otherwise
 356       err = "conj requires list or vector"
 357       return "ERR"
 358     end
 359
 360 mal_seq: procedure expose values. env. err /* mal_conj(a) */
 361   a = arg(1)
 362   select
 363     when string?(a) then do
 364       str = obj_val(a)
 365       if length(str) == 0 then return new_nil()
 366       seq = ""
 367       do i=1 to length(str)
 368         element = new_string(substr(str, i, 1))
 369         if i == 1 then
 370           seq = element
 371         else
 372           seq = seq || " " || element
 373       end
 374       return new_list(seq)
 375     end
 376     when list?(a) then do
 377       if count_elements(a) == 0 then return new_nil()
 378       return a
 379     end
 380     when vector?(a) then do
 381       if count_elements(a) == 0 then return new_nil()
 382       return new_list(obj_val(a))
 383     end
 384     when nil?(a) then return new_nil()
 385     otherwise
 386       err = "seq requires string or list or vector or nil"
 387       return "ERR"
 388     end
 389
 390 mal_with_meta: procedure expose values. /* mal_with_meta(a, b) */
 391   new_obj = obj_clone_and_set_meta(arg(1), arg(2))
 392   if new_obj == "" then return arg(1)
 393   return new_obj
 394
 395 mal_meta: procedure expose values. /* mal_meta(a) */
 396   meta = obj_meta(arg(1))
 397   if meta == "" then return new_nil()
 398   return meta
 399
 400 mal_atom: procedure expose values. /* mal_atom(a) */
 401   return new_atom(arg(1))
 402
 403 mal_atom?: procedure expose values. /* mal_atom?(a) */
 404   return new_boolean(atom?(arg(1)))
 405
 406 mal_deref: procedure expose values. /* mal_deref(a) */
 407   return obj_val(arg(1))
 408
 409 mal_reset!: procedure expose values. /* mal_reset!(a, new_val) */
 410   return atom_set(arg(1), arg(2))
 411
 412 mal_swap!: procedure expose values. env. err /* mal_swap!(a, fn, ...) */
 413   atom = arg(1)
 414   fn = arg(2)
 415   atom_val = obj_val(atom)
 416   seq = atom_val
 417   do i=3 to arg()
 418     seq = seq || " " || arg(i)
 419   end
 420   new_val = apply_function(fn, new_list(seq))
 421   if new_val == "ERR" then return "ERR"
 422   return atom_set(atom, new_val)
 423
 424 mal_rexx_eval: procedure expose values. /* mal_rexx_eval(..., a) */
 425   do i=1 to (arg() - 1)
 426     interpret obj_val(arg(i))
 427   end
 428   last_arg = arg(arg())
 429   if nil?(last_arg) then return new_nil()
 430   last_arg_str = obj_val(last_arg)
 431   if length(last_arg_str) == 0 then return new_nil()
 432   rexx_eval_res = ""
 433   interpret "rexx_eval_res = " || last_arg_str
 434   if datatype(rexx_eval_res) == "NUM" then
 435     return new_number(rexx_eval_res)
 436   else
 437     return new_string(rexx_eval_res)
 438
 439 get_core_ns: procedure /* get_core_ns() */
 440   return "=           mal_equal?"      ,
 441          "throw       mal_throw"       ,
 442                                        ,
 443          "nil?        mal_nil?"        ,
 444          "true?       mal_true?"       ,
 445          "false?      mal_false?"      ,
 446          "string?     mal_string?"     ,
 447          "symbol      mal_symbol"      ,
 448          "symbol?     mal_symbol?"     ,
 449          "keyword     mal_keyword"     ,
 450          "keyword?    mal_keyword?"    ,
 451          "number?     mal_number?"     ,
 452          "fn?         mal_fn?"         ,
 453          "macro?      mal_macro?"      ,
 454                                        ,
 455          "pr-str      mal_pr_str"      ,
 456          "str         mal_str"         ,
 457          "prn         mal_prn"         ,
 458          "println     mal_println"     ,
 459          "read-string mal_read_string" ,
 460          "readline    mal_readline"    ,
 461          "slurp       mal_slurp"       ,
 462                                        ,
 463          "<           mal_lt"          ,
 464          "<=          mal_lte"         ,
 465          ">           mal_gt"          ,
 466          ">=          mal_gte"         ,
 467          "+           mal_add"         ,
 468          "-           mal_sub"         ,
 469          "*           mal_mul"         ,
 470          "/           mal_div"         ,
 471          "time-ms     mal_time_ms"     ,
 472                                        ,
 473          "list        mal_list"        ,
 474          "list?       mal_list?"       ,
 475          "vector      mal_vector"      ,
 476          "vector?     mal_vector?"     ,
 477          "hash-map    mal_hash_map"    ,
 478          "map?        mal_map?"        ,
 479          "assoc       mal_assoc"       ,
 480          "dissoc      mal_dissoc"      ,
 481          "get         mal_get"         ,
 482          "contains?   mal_contains?"   ,
 483          "keys        mal_keys"        ,
 484          "vals        mal_vals"        ,
 485                                        ,
 486          "sequential? mal_sequential?" ,
 487          "cons        mal_cons"        ,
 488          "concat      mal_concat"      ,
 489          "nth         mal_nth"         ,
 490          "first       mal_first"       ,
 491          "rest        mal_rest"        ,
 492          "empty?      mal_empty?"      ,
 493          "count       mal_count"       ,
 494          "apply       mal_apply"       ,
 495          "map         mal_map"         ,
 496                                        ,
 497          "conj        mal_conj"        ,
 498          "seq         mal_seq"         ,
 499                                        ,
 500          "meta        mal_meta"        ,
 501          "with-meta   mal_with_meta"   ,
 502          "atom        mal_atom"        ,
 503          "atom?       mal_atom?"       ,
 504          "deref       mal_deref"       ,
 505          "reset!      mal_reset!"      ,
 506          "swap!       mal_swap!"       ,
 507                                        ,
 508          "rexx-eval   mal_rexx_eval"
 509
 510 #endif