REM > core function library for mal in BBC BASIC

REM  BBC BASIC doesn't have function pointers.  There are essentially
REM  two ways to work around this.  One is to use the BASIC EVAL function,
REM  constructing a string that will call an arbitrary function with the
REM  specified arguments.  The other is to us a big CASE statement.
REM  Following the suggestion in Hints.md, this code takes the latter
REM  approach.

DEF PROCcore_ns
  RESTORE +0
  REM  The actual DATA statements are embedded in the dispatch table below.
ENDPROC

REM  Call a core function, taking the function number and a mal list of
REM  objects to pass as arguments.
DEF FNcore_call(fn%, args%)
  LOCAL args%(), arg$
  DIM args%(1)
  CASE fn% OF
    DATA +, 0
    WHEN 0
      PROCcore_prepare_args("ii", "+")
      =FNalloc_int(args%(0) + args%(1))
    DATA -, 1
    WHEN 1
      PROCcore_prepare_args("ii", "-")
      =FNalloc_int(args%(0) - args%(1))
    DATA *, 2
    WHEN 2
      PROCcore_prepare_args("ii", "*")
      =FNalloc_int(args%(0) * args%(1))
    DATA /, 3
    WHEN 3
      PROCcore_prepare_args("ii", "/")
      =FNalloc_int(args%(0) DIV args%(1))
    DATA list, 5
    WHEN 5
      =args%
    DATA list?, 6
    WHEN 6
      PROCcore_prepare_args("?", "list?")
      =FNalloc_boolean(FNis_list(args%(0)))
    DATA empty?, 7
    WHEN 7
      PROCcore_prepare_args("l", "empty?")
      =FNalloc_boolean(FNis_empty(args%(0)))
    DATA count, 8
    WHEN 8
      PROCcore_prepare_args("C", "count")
      IF FNis_nil(args%(0)) THEN =FNalloc_int(0)
      =FNalloc_int(FNlist_len(args%(0)))
    DATA =, 9
    WHEN 9
      PROCcore_prepare_args("??", "=")
      =FNalloc_boolean(FNcore_equal(args%(0), args%(1)))
    DATA <, 10
    WHEN 10
      PROCcore_prepare_args("ii", "<")
      =FNalloc_boolean(args%(0) < args%(1))
    DATA <=, 11
    WHEN 11
      PROCcore_prepare_args("ii", "<=")
      =FNalloc_boolean(args%(0) <= args%(1))
    DATA >, 12
    WHEN 12
      PROCcore_prepare_args("ii", ">")
      =FNalloc_boolean(args%(0) > args%(1))
    DATA >=, 13
    WHEN 13
      PROCcore_prepare_args("ii", ">=")
      =FNalloc_boolean(args%(0) >= args%(1))
    DATA read-string, 14
    WHEN 14
      PROCcore_prepare_args("s", "read-string")
      =FNread_str(arg$)
    DATA slurp, 15
    WHEN 15
      PROCcore_prepare_args("s", "slurp")
      =FNalloc_string(FNcore_slurp(arg$))
    DATA eval, 16
    WHEN 16
      PROCcore_prepare_args("?", "eval")
      =FNEVAL(args%(0), repl_env%)
    DATA pr-str, 17
    WHEN 17
      =FNalloc_string(FNcore_print(TRUE, " ", args%))
    DATA str, 18
    WHEN 18
      =FNalloc_string(FNcore_print(FALSE, "", args%))
    DATA prn, 4
    WHEN 4
      PRINT FNcore_print(TRUE, " ", args%)
      =FNnil
    DATA println, 19
    WHEN 19
      PRINT FNcore_print(FALSE, " ", args%)
      =FNnil
    DATA atom, 20
    WHEN 20
      PROCcore_prepare_args("?", "atom")
      =FNalloc_atom(args%(0))
    DATA atom?, 21
    WHEN 21
      PROCcore_prepare_args("?", "atom?")
      =FNalloc_boolean(FNis_atom(args%(0)))
    DATA deref, 22
    WHEN 22
      PROCcore_prepare_args("a", "deref")
      =FNatom_deref(args%(0))
    DATA reset!, 23
    WHEN 23
      PROCcore_prepare_args("a?", "reset!")
      PROCatom_reset(args%(0), args%(1))
      =args%(1)
    DATA swap!, 24
    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))
    DATA cons, 25
    WHEN 25
      PROCcore_prepare_args("?l", "cons")
      =FNalloc_pair(args%(0), args%(1))
    DATA concat, 26
    WHEN 26
      =FNcore_concat(args%)
    DATA nth, 27
    WHEN 27
      PROCcore_prepare_args("li", "nth")
      =FNlist_nth(args%(0), args%(1))
    DATA first, 28
    WHEN 28
      PROCcore_prepare_args("l", "first")
      IF FNis_empty(args%(0)) OR FNis_nil(args%(0)) THEN =FNnil
      =FNlist_car(args%(0))
    DATA rest, 29
    WHEN 29
      PROCcore_prepare_args("l", "rest")
      IF FNis_empty(args%(0)) THEN =FNempty
      =FNlist_cdr(args%(0))
    DATA throw, 30
    WHEN 30
      PROCcore_prepare_args("?", "throw")
      MAL_ERR% = args%(0)
      ERROR &40E80900, "Mal exception: " + FNpr_str(args%(0), FALSE)
    DATA apply, 31
    WHEN 31
      PROCcore_prepare_args("f?*", "apply")
      =FNcore_apply(args%(0), FNcore_apply_args(FNalloc_pair(args%(1), args%)))
    DATA map, 32
    WHEN 32
      PROCcore_prepare_args("fl", "map")
      =FNcore_map(args%(0), args%(1))
    DATA nil?, 33
    WHEN 33
      PROCcore_prepare_args("?", "nil?")
      =FNalloc_boolean(FNis_nil(args%(0)))
    DATA true?, 34
    WHEN 34
      PROCcore_prepare_args("?", "true?")
      IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE)
      =args%(0)
    DATA false?, 35
    WHEN 35
      PROCcore_prepare_args("?", "false?")
      IF NOT FNis_boolean(args%(0)) THEN =FNalloc_boolean(FALSE)
      =FNalloc_boolean(NOT FNunbox_boolean(args%(0)))
    DATA symbol?, 36
    WHEN 36
      PROCcore_prepare_args("?", "symbol?")
      =FNalloc_boolean(FNis_symbol(args%(0)))
    DATA "", -1
  ENDCASE
ERROR &40E809F1, "Call to non-existent core function"

DEF PROCcore_prepare_args(spec$, fn$)
  REM  Check that a core function is being provided with the correct
  REM  number and type of arguments and unbox them as appropriate.
  REM  spec$ is the argument specification as a string.  Each character
  REM  represents an argument:

  REM  "i" - Must be an integer;  unbox into args%()
  REM  "s" - Must be a string;    unbox into arg$
  REM  "l" - Must be a list;      stuff into args%()
  REM  "f" - Must be a function;  stuff into args%()
  REM  "a" - Must be an atom;     stuff into args%()
  REM  "C" - Must be 'count'able  stuff into args%()
  REM  "?" - Any single argument  stuff into args%()
  REM  "*" - Any number of (trailing) arguments; leave in args%

  REM  This function shares some local variables with FNcore_call.

  LOCAL i%, val%

  IF RIGHT$(spec$) = "*" THEN
    spec$ = LEFT$(spec$)
    IF FNlist_len(args%) < LEN(spec$) THEN
      ERROR &40E80921, "Core function '"+fn$+"' requires at least "+STR$(LEN(spec$))+" arguments"
    ENDIF
  ELSE
    IF FNlist_len(args%) <> LEN(spec$) THEN
      ERROR &40E80921, "Core function '"+fn$+"' requires "+STR$(LEN(spec$))+" arguments"
    ENDIF
  ENDIF
  FOR i% = 1 TO LEN(spec$)
    val% = FNlist_car(args%)
    CASE MID$(spec$, i%, 1) OF
      WHEN "i"
        IF NOT FNis_int(val%) THEN
          ERROR &40E80911, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an integer"
        ENDIF
        args%(i% - 1) = FNunbox_int(val%)
      WHEN "s"
        IF NOT FNis_string(val%) THEN
          ERROR &40E80914, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a list"
        ENDIF
        arg$ = FNunbox_string(val%)
      WHEN "l"
        IF NOT FNis_list(val%) THEN
          ERROR &40E80916, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a list"
        ENDIF
        args%(i% - 1) = val%
      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"
        ENDIF
        args%(i% - 1) = val%
      WHEN "a"
        IF NOT FNis_atom(val%) THEN
          ERROR &40E8091C, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be an atom"
        ENDIF
        args%(i% - 1) = val%
      WHEN "C"
        IF NOT FNis_list(val%) AND NOT FNis_nil(val%) THEN
          ERROR &40E8091F, "Argument "+STR$(i%)+" to core function '"+fn$+"' must be a countable value"
        ENDIF
        args%(i% - 1) = val%
      WHEN "?"
        args%(i% - 1) = val%
    ENDCASE
    args% = FNlist_cdr(args%)
  NEXT i%
ENDPROC

REM  Innards of the '=' function.
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%)
  ENDIF
  IF FNis_string(a%) AND FNis_string(b%) THEN
    =FNunbox_string(a%) = FNunbox_string(b%)
  ENDIF
  IF FNis_list(a%) AND FNis_list(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(FNlist_car(a%), FNlist_car(b%)) THEN =FALSE
    =FNcore_equal(FNlist_cdr(a%), FNlist_cdr(b%))
  ENDIF
=FALSE

REM  Innards of the 'slurp' function.
DEF FNcore_slurp(file$)
  LOCAL f%, out$
  f% = OPENIN(file$)
  IF f% = 0 THEN ERROR &40E80940, "File '"+file$+"' not found"
  WHILE NOT EOF#f%
    out$ += GET$#f%
    REM  GET$# doesn't include a trailing newline.
    out$ += CHR$(10)
  ENDWHILE
  CLOSE#f%
=out$

REM  General-purpose printing function
DEF FNcore_print(print_readably%, sep$, args%)
  LOCAL out$
  IF FNis_empty(args%) THEN =""
  out$ = FNpr_str(FNlist_car(args%), print_readably%)
  args% = FNlist_cdr(args%)
  WHILE NOT FNis_empty(args%)
    out$ += sep$
    out$ += FNpr_str(FNlist_car(args%), print_readably%)
    args% = FNlist_cdr(args%)
  ENDWHILE
=out$

REM  Innards of the 'apply' function, also used by 'swap!'
DEF FNcore_apply(fn%, args%)
  LOCAL ast%, env%
  IF FNis_corefn(fn%) THEN =FNcore_call(FNunbox_corefn(fn%), args%)
  IF FNis_fn(fn%) THEN
    ast% = FNfn_ast(fn%)
    env% = FNnew_env(FNfn_env(fn%), FNfn_params(fn%), args%)
    =FNEVAL(ast%, env%)
  ENDIF
ERROR &40E80918, "Not a function"

REM  Innards of 'concat' function
DEF FNcore_concat(args%)
  LOCAL tail%
  IF FNis_empty(args%) THEN =FNempty
  tail% = FNcore_concat(FNlist_cdr(args%))
=FNcore_concat1(FNlist_car(args%), tail%)
  
DEF FNcore_concat1(prefix%, tail%)
  IF FNis_empty(prefix%) THEN =tail%
=FNalloc_pair(FNlist_car(prefix%), FNcore_concat1(FNlist_cdr(prefix%), tail%))

REM  Recursively assemble the argument list for 'apply'
DEF FNcore_apply_args(args%)
  IF FNis_empty(FNlist_cdr(args%)) THEN =FNlist_car(args%)
=FNalloc_pair(FNlist_car(args%), FNcore_apply_args(FNlist_cdr(args%)))

REM  Innards of the 'map' function
DEF FNcore_map(fn%, args%)
  LOCAL car%, cdr%
  IF FNis_empty(args%) THEN =args%
  car% = FNcore_apply(fn%, FNalloc_pair(FNlist_car(args%), FNempty))
  cdr% = FNcore_map(fn%, FNlist_cdr(args%))
=FNalloc_pair(car%, cdr%)

REM Local Variables:
REM indent-tabs-mode: nil
REM End: