HCoop Git - jackhill/mal.git/blob

1 REM > core function library for mal in BBC BASIC

3 REM BBC BASIC doesn't have function pointers. There are essentially

4 REM two ways to work around this. One is to use the BASIC EVAL function,

5 REM constructing a string that will call an arbitrary function with the

6 REM specified arguments. The other is to us a big CASE statement.

7 REM Following the suggestion in Hints.md, this code takes the latter

8 REM approach.

10 DEF PROCcore_ns

11 RESTORE +0

12 REM The actual DATA statements are embedded in the dispatch table below.

13 ENDPROC

15 REM Call a core function, taking the function number and a mal list of

16 REM objects to pass as arguments.

17 DEF FNcore_call(fn%, args%)

18 LOCAL args%(), arg$

19 DIM args%(1)

20 CASE fn% OF

21 DATA +, 0

22 WHEN 0

       PROCcore_prepare_args("ii", "+")

       =FNalloc_int(args%(0) + args%(1))

25 DATA -, 1

26 WHEN 1

       PROCcore_prepare_args("ii", "-")

       =FNalloc_int(args%(0) - args%(1))

29 DATA *, 2

30 WHEN 2

       PROCcore_prepare_args("ii", "*")

       =FNalloc_int(args%(0) * args%(1))

33 DATA /, 3

34 WHEN 3

       PROCcore_prepare_args("ii", "/")

       =FNalloc_int(args%(0) DIV args%(1))

37 DATA list, 5

38 WHEN 5

39 =FNas_list(args%)

40 DATA list?, 6

41 WHEN 6

       PROCcore_prepare_args("?", "list?")

       =FNalloc_boolean(FNis_list(args%(0)))

44 DATA empty?, 7

45 WHEN 7

       PROCcore_prepare_args("l", "empty?")

       =FNalloc_boolean(FNis_empty(args%(0)))

48 DATA count, 8

49 WHEN 8

       PROCcore_prepare_args("C", "count")

       IF FNis_nil(args%(0)) THEN =FNalloc_int(0)

       =FNalloc_int(FNcount(args%(0)))

53 DATA =, 9

54 WHEN 9

       PROCcore_prepare_args("??", "=")

       =FNalloc_boolean(FNcore_equal(args%(0), args%(1)))

57 DATA <, 10

58 WHEN 10

       PROCcore_prepare_args("ii", "<")

       =FNalloc_boolean(args%(0) < args%(1))

61 DATA <=, 11

62 WHEN 11

       PROCcore_prepare_args("ii", "<=")

       =FNalloc_boolean(args%(0) <= args%(1))

65 DATA >, 12

66 WHEN 12

       PROCcore_prepare_args("ii", ">")

       =FNalloc_boolean(args%(0) > args%(1))

69 DATA >=, 13

70 WHEN 13

       PROCcore_prepare_args("ii", ">=")

       =FNalloc_boolean(args%(0) >= args%(1))

73 DATA read-string, 14

74 WHEN 14

       PROCcore_prepare_args("t", "read-string")

       =FNread_str(args%(0))

77 DATA slurp, 15

78 WHEN 15

       PROCcore_prepare_args("s", "slurp")

80 =FNcore_slurp(arg$)

81 DATA eval, 16

82 WHEN 16

       PROCcore_prepare_args("?", "eval")

       =FNEVAL(args%(0), repl_env%)

85 DATA pr-str, 17

86 WHEN 17

       =FNcore_print(TRUE, " ", args%)

88 DATA str, 18

89 WHEN 18

       =FNcore_print(FALSE, "", args%)

91 DATA prn, 4

92 WHEN 4

       PRINT FNunbox_string(FNcore_print(TRUE, " ", args%))

94 =FNnil

95 DATA println, 19

96 WHEN 19

       PRINT FNunbox_string(FNcore_print(FALSE, " ", args%))

98 =FNnil

99 DATA atom, 20

100 WHEN 20

       PROCcore_prepare_args("?", "atom")

       =FNalloc_atom(args%(0))

103 DATA atom?, 21

104 WHEN 21

       PROCcore_prepare_args("?", "atom?")

       =FNalloc_boolean(FNis_atom(args%(0)))

107 DATA deref, 22

108 WHEN 22

       PROCcore_prepare_args("a", "deref")

       =FNatom_deref(args%(0))

111 DATA reset!, 23

112 WHEN 23

       PROCcore_prepare_args("a?", "reset!")

       PROCatom_reset(args%(0), args%(1))

115 =args%(1)

116 DATA swap!, 24

117 WHEN 24

       PROCcore_prepare_args("af*", "swap!")

       PROCatom_reset(args%(0), FNcore_apply(args%(1), FNalloc_pair(FNatom_deref(args%(0)), args%)))

       =FNatom_deref(args%(0))

121 DATA cons, 25

122 WHEN 25

       PROCcore_prepare_args("?l", "cons")

       =FNalloc_pair(args%(0), args%(1))

125 DATA concat, 26

126 WHEN 26

127 =FNcore_concat(args%)

128 DATA nth, 27

129 WHEN 27

       PROCcore_prepare_args("li", "nth")

       =FNnth(args%(0), args%(1))

132 DATA first, 28

133 WHEN 28

       PROCcore_prepare_args("C", "first")

       IF FNis_nil(args%(0)) THEN =FNnil

       =FNfirst(args%(0))

137 DATA rest, 29

138 WHEN 29

       PROCcore_prepare_args("C", "rest")

       IF FNis_nil(args%(0)) THEN =FNempty

       =FNas_list(FNrest(args%(0)))

142 DATA throw, 30

143 WHEN 30

       PROCcore_prepare_args("?", "throw")

145 MAL_ERR% = args%(0)

       ERROR &40E80900, "Mal exception: " + FNunbox_string(FNpr_str(args%(0), FALSE))

147 DATA apply, 31

148 WHEN 31

       PROCcore_prepare_args("f?*", "apply")

       =FNcore_apply(args%(0), FNcore_apply_args(FNalloc_pair(args%(1), args%)))

151 DATA map, 32

152 WHEN 32

       PROCcore_prepare_args("fl", "map")

       =FNcore_map(args%(0), args%(1))

155 DATA nil?, 33

156 WHEN 33

       PROCcore_prepare_args("?", "nil?")

       =FNalloc_boolean(FNis_nil(args%(0)))

159 DATA true?, 34

160 WHEN 34

       PROCcore_prepare_args("?", "true?")

       IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE)

163 =args%(0)

164 DATA false?, 35

165 WHEN 35

       PROCcore_prepare_args("?", "false?")

       IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE)

       =FNalloc_boolean(NOT FNunbox_boolean(args%(0)))

169 DATA symbol?, 36

170 WHEN 36

       PROCcore_prepare_args("?", "symbol?")

       =FNalloc_boolean(FNis_symbol(args%(0)))

173 DATA symbol, 37

174 WHEN 37

       PROCcore_prepare_args("s", "symbol")

176 =FNalloc_symbol(arg$)

177 DATA keyword, 38

178 WHEN 38

       PROCcore_prepare_args("s", "keyword")

       IF LEFT$(arg$, 1) <> CHR$(127) THEN arg$ = CHR$(127) + arg$

181 =FNalloc_string(arg$)

182 DATA keyword?, 39

183 WHEN 39

       PROCcore_prepare_args("?", "keyword?")

       IF FNis_string(args%(0)) THEN

         =FNalloc_boolean(LEFT$(FNunbox_string(args%(0)), 1) = CHR$(127))

187 ENDIF

       =FNalloc_boolean(FALSE)

189 DATA vector, 40

190 WHEN 40

191 =FNas_vector(args%)

192 DATA vector?, 41

193 WHEN 41

       PROCcore_prepare_args("?", "vector?")

       =FNalloc_boolean(FNis_vector(args%(0)))      

196 DATA sequential?, 42

197 WHEN 42

       PROCcore_prepare_args("?", "sequential?")

       =FNalloc_boolean(FNis_seq(args%(0)))

200 DATA hash-map, 43

201 WHEN 43

       =FNcore_assoc(FNempty_hashmap, args%)

203 DATA map?, 44

204 WHEN 44

       PROCcore_prepare_args("?", "map?")

       =FNalloc_boolean(FNis_hashmap(args%(0)))

207 DATA assoc, 45

208 WHEN 45

       PROCcore_prepare_args("h*", "assoc")

       =FNcore_assoc(args%(0), args%)

211 DATA dissoc, 46

212 WHEN 46

       PROCcore_prepare_args("h*", "dissoc")

214 WHILE NOT FNis_empty(args%)

         args%(0) = FNhashmap_remove(args%(0), FNunbox_string(FNfirst(args%)))

216 args% = FNrest(args%)

217 ENDWHILE

218 =args%(0)

219 DATA get, 47

220 WHEN 47

       IF FNis_nil(FNfirst(args%)) THEN =FNnil

       PROCcore_prepare_args("hs", "get")

       =FNhashmap_get(args%(0), arg$)

224 DATA contains?, 48

225 WHEN 48

       PROCcore_prepare_args("hs", "contains?")

       =FNalloc_boolean(FNhashmap_contains(args%(0), arg$))

228 DATA keys, 49

229 WHEN 49

       PROCcore_prepare_args("h", "keys")

       =FNhashmap_keys(args%(0))

232 DATA vals, 50

233 WHEN 50

       PROCcore_prepare_args("h", "vals")

       =FNhashmap_vals(args%(0))

236 DATA readline, 51

237 WHEN 51

       PROCcore_prepare_args("s", "readline")

239 PRINT arg$;

240 LINE INPUT "" arg$

241 =FNalloc_string(arg$)

242 DATA meta, 52

243 WHEN 52

       PROCcore_prepare_args("?", "meta")

       =FNmeta(args%(0))

246 DATA with-meta, 53

247 WHEN 53

       PROCcore_prepare_args("??", "with-meta")

       =FNwith_meta(args%(0), args%(1))

250 DATA time-ms, 54

251 WHEN 54

       PROCcore_prepare_args("", "time-ms")

       =FNalloc_int(TIME * 10)

254 DATA conj, 55

255 WHEN 55

       PROCcore_prepare_args("l*", "conj")

       IF FNis_list(args%(0)) THEN

258 WHILE NOT FNis_empty(args%)

           args%(0) = FNalloc_pair(FNfirst(args%), args%(0))

260 args% = FNrest(args%)

261 ENDWHILE

262 =args%(0)

263 ELSE : REM args%(0) is a vector

         =FNas_vector(FNcore_concat1(args%(0), args%))

265 ENDIF

266 DATA string?, 56

267 WHEN 56

       PROCcore_prepare_args("?", "string?")

       IF FNis_string(args%(0)) THEN

         =FNalloc_boolean(LEFT$(FNunbox_string(args%(0)), 1) <> CHR$(127))

271 ENDIF

       =FNalloc_boolean(FALSE)

273 DATA number?, 57

274 WHEN 57

       PROCcore_prepare_args("?", "number?")

       =FNalloc_boolean(FNis_int(args%(0)))

277 DATA fn?, 58

278 WHEN 58

       PROCcore_prepare_args("?", "fn?")

       =FNalloc_boolean(FNis_nonmacro_fn(args%(0)) OR FNis_corefn(args%(0)))

281 DATA macro?, 59

282 WHEN 59

       PROCcore_prepare_args("?", "macro?")

       =FNalloc_boolean(FNis_macro(args%(0)))

285 DATA seq, 60

286 WHEN 60

       PROCcore_prepare_args("?", "seq")

       =FNcore_seq(args%(0))

289 DATA "", -1

290 ENDCASE

 ERROR &40E809F1, "Call to non-existent core function"

292

293 DEF PROCcore_prepare_args(spec$, fn$)

294 REM Check that a core function is being provided with the correct

295 REM number and type of arguments and unbox them as appropriate.

296 REM spec$ is the argument specification as a string. Each character

297 REM represents an argument:

298

299 REM "i" - Must be an integer; unbox into args%()

300 REM "s" - Must be a string; unbox into arg$

301 REM "t" - Must be a string; stuff into args%()

302 REM "l" - Must be a sequence; stuff into args%()

303 REM "f" - Must be a function; stuff into args%()

304 REM "a" - Must be an atom; stuff into args%()

305 REM "h" - Must be a hash-map; stuff into args%()

306 REM "C" - Must be 'count'able stuff into args%()

307 REM "?" - Any single argument stuff into args%()

308 REM "*" - Any number of (trailing) arguments; leave in args%

309

310 REM This function shares some local variables with FNcore_call.

311

312 LOCAL i%, val%

313

   IF RIGHT$(spec$) = "*" THEN

315 spec$ = LEFT$(spec$)

     IF FNcount(args%) < LEN(spec$) THEN

       ERROR &40E80921, "Core function '"+fn$+"' requires at least "+STR$(LEN(spec$))+" arguments"

318 ENDIF

319 ELSE

     IF FNcount(args%) <> LEN(spec$) THEN

       ERROR &40E80921, "Core function '"+fn$+"' requires "+STR$(LEN(spec$))+" arguments"

322 ENDIF

323 ENDIF

   FOR i% = 1 TO LEN(spec$)

325 val% = FNfirst(args%)

     CASE MID$(spec$, i%, 1) OF

327 WHEN "i"

         IF NOT FNis_int(val%) THEN

           ERROR &40E80911, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an integer"

330 ENDIF

         args%(i% - 1) = FNunbox_int(val%)

332 WHEN "s"

         IF NOT FNis_string(val%) THEN

           ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a string"

335 ENDIF

336 arg$ = FNunbox_string(val%)

337 WHEN "t"

         IF NOT FNis_string(val%) THEN

           ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a string"

340 ENDIF

         args%(i% - 1) = val%

342 WHEN "l"

         IF NOT FNis_seq(val%) THEN

           ERROR &40E80916, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a sequence"

345 ENDIF

         args%(i% - 1) = val%

347 WHEN "f"

         IF NOT FNis_fn(val%) AND NOT FNis_corefn(val%) THEN

           ERROR &40E80919, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a function"

350 ENDIF

         args%(i% - 1) = val%

352 WHEN "a"

         IF NOT FNis_atom(val%) THEN

           ERROR &40E8091C, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an atom"

355 ENDIF

         args%(i% - 1) = val%

357 WHEN "h"

         IF NOT FNis_hashmap(val%) THEN

           ERROR &40E8091D, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a hash-map"

360 ENDIF

         args%(i% - 1) = val%

362 WHEN "C"

         IF NOT FNis_seq(val%) AND NOT FNis_nil(val%) THEN

           ERROR &40E8091F, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a countable value"

365 ENDIF

         args%(i% - 1) = val%

367 WHEN "?"

         args%(i% - 1) = val%

369 ENDCASE

370 args% = FNrest(args%)

371 NEXT i%

372 ENDPROC

373

374 REM Innards of the '=' function.

375 DEF FNcore_equal(a%, b%)

   IF a% = b% THEN =TRUE

   IF FNis_int(a%) AND FNis_int(b%) THEN =FNunbox_int(a%) = FNunbox_int(b%)

   IF FNis_symbol(a%) AND FNis_symbol(b%) THEN

     =FNunbox_symbol(a%) = FNunbox_symbol(b%)

380 ENDIF

   IF FNis_string(a%) AND FNis_string(b%) THEN

     =FNunbox_string(a%) = FNunbox_string(b%)

383 ENDIF

   IF FNis_seq(a%) AND FNis_seq(b%) THEN

     IF FNis_empty(a%) AND FNis_empty(b%) THEN =TRUE

     IF FNis_empty(a%) <> FNis_empty(b%) THEN =FALSE

     IF NOT FNcore_equal(FNfirst(a%), FNfirst(b%)) THEN =FALSE

     =FNcore_equal(FNrest(a%), FNrest(b%))

389 ENDIF

   IF FNis_hashmap(a%) AND FNis_hashmap(b%) THEN

391 REM Take advantage of the sorted keys in our hash-maps.

     IF FNcore_equal(FNhashmap_keys(a%), FNhashmap_keys(b%)) THEN

       IF FNcore_equal(FNhashmap_vals(a%), FNhashmap_vals(b%)) THEN =TRUE

394 ENDIF

395 ENDIF

396 =FALSE

397

398 REM Innards of the 'slurp' function.

399 DEF FNcore_slurp(file$)

400 LOCAL f%, out%

401 f% = OPENIN(file$)

   IF f% = 0 THEN ERROR &40E80940, "File '"+file$+"' not found"

403 out% = FNcore_slurp_channel(f%)

404 CLOSE#f%

405 =out%

406

407 DEF FNcore_slurp_channel(f%)

408 LOCAL this%

409 IF EOF#f% THEN =FNalloc_string("")

410 REM GET$# doesn't include a trailing newline.

411 this% = FNalloc_string(GET$#f% + CHR$(10))

412 =FNstring_concat(this%, FNcore_slurp_channel(f%))

413

414 REM General-purpose printing function

415 DEF FNcore_print(print_readably%, sep$, args%)

416 LOCAL out%

417 IF FNis_empty(args%) THEN =FNalloc_string("")

418 out% = FNpr_str(FNfirst(args%), print_readably%)

419 args% = FNrest(args%)

420 WHILE NOT FNis_empty(args%)

421 out% = FNstring_append(out%, sep$)

422 out% = FNstring_concat(out%, FNpr_str(FNfirst(args%), print_readably%))

423 args% = FNrest(args%)

424 ENDWHILE

425 =out%

426

427 REM Innards of the 'apply' function, also used by 'swap!'

428 DEF FNcore_apply(fn%, args%)

429 LOCAL ast%, env%

430 IF FNis_corefn(fn%) THEN =FNcore_call(FNunbox_corefn(fn%), args%)

431 IF FNis_fn(fn%) THEN

432 ast% = FNfn_ast(fn%)

433 env% = FNnew_env(FNfn_env(fn%), FNfn_params(fn%), args%)

434 =FNEVAL(ast%, env%)

435 ENDIF

436 ERROR &40E80918, "Not a function"

437

438 REM Innards of 'concat' function

439 DEF FNcore_concat(args%)

440 LOCAL tail%

441 IF FNis_empty(args%) THEN =FNempty

442 tail% = FNcore_concat(FNrest(args%))

443 =FNcore_concat1(FNfirst(args%), tail%)

444

445 DEF FNcore_concat1(prefix%, tail%)

446 IF FNis_empty(prefix%) THEN =tail%

447 =FNalloc_pair(FNfirst(prefix%), FNcore_concat1(FNrest(prefix%), tail%))

448

449 REM Recursively assemble the argument list for 'apply'

450 DEF FNcore_apply_args(args%)

451 IF FNis_empty(FNrest(args%)) THEN =FNfirst(args%)

452 =FNalloc_pair(FNfirst(args%), FNcore_apply_args(FNrest(args%)))

453

454 REM Innards of the 'map' function

455 DEF FNcore_map(fn%, args%)

456 LOCAL car%, cdr%

457 IF FNis_empty(args%) THEN =args%

458 car% = FNcore_apply(fn%, FNalloc_pair(FNfirst(args%), FNempty))

459 cdr% = FNcore_map(fn%, FNrest(args%))

460 =FNalloc_pair(car%, cdr%)

461

462 REM Innards of the 'hash-map' function

463 DEF FNcore_assoc(map%, args%)

464 LOCAL args%()

465 DIM args%(1)

466 WHILE NOT FNis_empty(args%)

     PROCcore_prepare_args("s?*", "hash-map")

468 map% = FNhashmap_set(map%, arg$, args%(1))

469 ENDWHILE

470 =map%

471

472 REM Innards of the 'seq' function

473 DEF FNcore_seq(val%)

474 LOCAL s$, i%

475 IF FNis_empty(val%) OR FNis_nil(val%) THEN =FNnil

476 IF FNis_list(val%) THEN =val%

477 IF FNis_vector(val%) THEN =FNas_list(val%)

478 IF FNis_string(val%) THEN

479 s$ = FNunbox_string(val%)

480 IF s$ = "" THEN =FNnil

481 val% = FNempty

482 FOR i% = LEN(s$) TO 1 STEP -1

483 val% = FNalloc_pair(FNalloc_string(MID$(s$, i%, 1)), val%)

484 NEXT i%

485 =val%

486 ENDIF

487 ERROR &40E8091F, "Argument to 'seq' must be list, vector, string, or nil"

488

489 REM Local Variables:

490 REM indent-tabs-mode: nil

491 REM End: