#!/bin/bash -xe
#| -*- mode: Shell-script; indent-tabs-mode: nil; fill-column: 80 -*-

cat >COPYING <<EOF
BSD 3-Clause License

Copyright (c) 2022, Robert van Engelen
Copyright (c) 2025, Jens Thiele <karme@karme.de>
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.

2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

3. Neither the name of the copyright holder nor the names of its
   contributors may be used to endorse or promote products derived from
   this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
EOF

set -o pipefail
iDSK c.dsk -n

cat >imagetocpc.scm <<'EOF'
#!/bin/sh
#| -*- mode: scheme; coding: utf-8; -*-
exec gosh -I. -- $0 "$@"
|#
(use gauche.process)
(use gauche.uvector)
(use gauche.sequence)
(use sxml.adaptor) ;; for assert

(debug-print-width 4000)

(define (read-header x)
  (when (not (zero? x))
    (let1 l (read-line)
      ;; todo: comment dosn't necessarily start at line
      (if (equal? (~ l 0) #\#)
        (read-header x)
        (read-header (- x 1))))))

(define (main args)
  (with-input-from-process
      ;; todo: uh ugly - imagemagick 7 (vs 6) somehow doesn't allow
      ;; to dither anymore when converting to bitmap. S.a:
      ;; https://github.com/ImageMagick/ImageMagick/discussions/5156
      ;;#?=`(sh -c ,#`"convert ,(shell-escape-string (cadr args)) \
      ;;                       -resize \"640x200!\" pgm:- \
      ;;               |pamditherbw -atk|convert pam:- pbm:-")
      #?=`(sh -c ,#`"convert ,(shell-escape-string (cadr args)) \
                             -resize \"640x200!\" pgm:- \
                     |pamditherbw|convert pam:- pbm:-")
      (lambda()
        (read-header 2)
        (let ((src (port->uvector (current-input-port)))
              (dst (make-uvector <u8vector> (- (ash 1 14) 1))))
          (assert (= (size-of src) (/ (* 640 200) 8)))
          (dotimes (y 200)
            (dotimes (x (/ 640 8))
              (uvector-set! dst
                            (+ (* 80 (quotient y 8))
                               (* 2048 (modulo y 8)) x)
                            (~ src (+ (* y (/ 640 8)) x)))))
          (write-uvector dst))))
  0)
EOF
chmod +x imagetocpc.scm

i=0;
for f in "$@"; do
    ./imagetocpc.scm "$f" > "$i"
    iDSK c.dsk -i "$i" -c c000 -e c000
    i=$((i+1))
done

# todo: many emulators hang on printer output!
{ cat <<EOF
mode 2
' print #8,"hello world from basic"
border 26:ink 0,26:ink 1,0
memory &1200-1
load "c.bin",&1200
'load "0",&c000
call &1200
EOF
}|nl -w1|unix2dos>lisp1k.bas
iDSK c.dsk -i lisp1k.bas -t 0
{ cat <<'EOF'
(define cls (lambda()(begin (call 47980) (call 48148))))
(define <= (lambda(x y)(not (< y x))))
(define rtr (lambda(r t)(if t (rtr (cons (car t) r) (cdr t)) r)))
(define reverse (lambda(t) (rtr () t)))
(define read-word (lambda(n)(reverse (rwr n))))
(define n? (lambda(c)(or (eq? c 110) (eq? c 240))))
(define w? (lambda(c)(or (eq? c 119) (eq? c 242))))
(define e? (lambda(c)(or (eq? c 101) (eq? c 243))))
(define s? (lambda(c)(or (eq? c 115) (eq? c 241))))
(define pair? (lambda(x)(eq? (type x) 4)))
(define equal? (lambda(x y)
 (or (eq? x y) (and (pair? x) (pair? y)
  (equal? (car x) (car y))
  (equal? (cdr x) (cdr y))))))
(define main (lambda() (begin
 (putchar 13)(putchar 10)
 (print "hello world from lisp1k")
 (putchar 13)(putchar 10)
 (set-echo! 1)
 (set-quiet! 0)
 (set-input! 0))))
(main)
EOF
}|unix2dos>A
echo -en '\0' >> A
iDSK c.dsk -i A -c c000 -e c000
cat > crt0_cpc.s <<EOF
;; FILE: crt0.s
;; Generic crt0.s for a Z80
;; From SDCC..
;; Modified to suit execution on the Amstrad CPC!
;; by H. Hansen 2003
;; Original lines has been marked out!
;; Updated to SDCC v3.3.0 by Mochilote in 2013
;; (Fixed initialization of global variables)

.module crt0
        .globl  _main

        .area _HEADER (ABS)
;; Reset vector
        .org    0x1200
        jp      init

        .org    0x$(bc <<<"obase=16;ibase=16;1200+10")

init:
        ;; Initialise global variables
        call    gsinit
        ;; hack to have bigger stack (todo: copy current stack? move at another place?)
        ld sp,#0xa000-1
        call    _main
        jp      _exit

;; Ordering of segments for the linker.
        .area   _HOME
        .area   _CODE
        .area   _INITIALIZER
        .area   _GSINIT
        .area   _GSFINAL

        .area   _DATA
        .area   _INITIALIZED
        .area   _BSEG
        .area   _BSS
        .area   _HEAP

  .area   _CODE
__clock::
        ret

_exit::
        ret

        .area   _GSINIT
gsinit::
        ld      bc, #l__INITIALIZER
        ld      a, b
        or      a, c
        jr      Z, gsinit_next
        ld      de, #s__INITIALIZED
        ld      hl, #s__INITIALIZER
        ldir
gsinit_next:

        .area   _GSFINAL
        ret
EOF
sdasz80 -go crt0_cpc.s
cat > util.s <<'EOF'
.area _CODE
_putchar::
        ld a,l
        call    0xbb5a
1$:
        ; output to printer
        ; (todo: many emulators hang on printer output!)
        ;call 0xbd2b
        ;jp nc,1$
        ret

_getchar::
        ; ld a,#63
        ; call 0xbb5a
        call 0xbb06
        ld d,#0x0
        ld e,a
        ret

;; load_file(char* fname, char* address)
;; fname => hl
;; address => de
_load_file::
        push de
        push hl
        call _strlen
        pop hl
        ; result in de
        ld b,e

        ; firmware function to open a file for reading
        ; B = length of the filename in characters
        ; HL = address of the start of the filename
        call #0xbc77 ;;cas_in_open

        ;; firmware function to load the entire file
        ;; this will work with files that have a AMSDOS header (ASCII
        ;; files do not have a header)
        ;; HL = load address
        ;; read file
        pop de
        ld h,d
        ld l,e
        call #0xbc83 ;;cas_in_direct

        ;; firmware function to close a file opened for reading
        call #0xbc7a ;;cas_in_close
        ret

_JP_HL::
        jp (hl)
EOF
sdasz80 -go util.s

cat > c.c <<'EOF'
/* note: this is a crippled version of lisp-pr-single.c
   from:
   https://github.com/Robert-van-Engelen/lisp
*/

/* lisp-pr-single.c Lisp with pointer reversal mark-sweep GC and NaN boxing by Robert A. van Engelen 2022 BSD-3 license
        - single precision floating point, symbols, strings, lists, proper closures, and macros
        - over 40 built-in Lisp primitives
        - lexically-scoped locals in lambda, let, let*, letrec, letrec*
        - proper tail-recursion, including tail calls through begin, cond, if, let, let*, letrec, letrec*
        - exceptions and error handling with safe return to REPL after an error
        - break with CTRL-C to return to the REPL (compile: lisp.c -DHAVE_SIGNAL_H)
        - REPL with readline (compile: lisp.c -DHAVE_READLINE_H -lreadline)
        - load Lisp source code files
        - execution tracing to display Lisp evaluation steps
        - mark-sweep garbage collector with efficient "pointer reversal" to recycle unused cons pair cells
        - compacting garbage collector to recycle unused atoms and strings */

#include <stdlib.h>
#include <stdio.h>
#include <stdint.h>             /* uint32_t */
#include <string.h>
#include <setjmp.h>

void abort(void)
{
        printf("abort: todo\r\n");
        while(1)
              ;
}

/* single precision floating point output format */
#define FLOAT "%.7g"

/* DEBUG: always run GC when allocating cells and atoms/strings on the heap */
#ifdef DEBUG
#define ALWAYS_GC 1
#else
#define ALWAYS_GC 0
#endif

/*----------------------------------------------------------------------------*\
 |      LISP EXPRESSION TYPES AND NAN BOXING                                  |
\*----------------------------------------------------------------------------*/

/* we only need two types to implement a Lisp interpreter:
        I      unsigned integer (32 bit unsigned)
        L      Lisp expression (single precision float with NaN boxing)
   I variables and function parameters are named as follows:
        i,j,k  any unsigned integer, e.g. a NaN-boxed ordinal value or index
        t      a NaN-boxing tag
   L variables and function parameters are named as follows:
        x,y    any Lisp expression
        n      number
        t,s    list
        f      function or Lisp primitive
        p      pair, a cons of two Lisp expressions
        e,d    environment, a list of pairs, e.g. created with (define v x)
        v      the name of a variable (an atom) or a list of variables */
#define I uint32_t
#define L float

/* T(x) returns the tag bits of a NaN-boxed Lisp expression x */
#define T(x) (*(I*)&x >> 20)

/* primitive, atom, string, cons, closure, macro and nil tags for NaN boxing (reserve 0x7f8 for nan) */
enum { PRIM = 0x7f9, ATOM = 0x7fa, STRG = 0x7fb, CONS = 0x7fc, CLOS = 0x7fe, MACR = 0x7ff, NIL = 0xfff };

/* box(t,i): returns a new NaN-boxed float with tag t and 20 bits ordinal i
   ord(x):   returns the 20 bits ordinal of the NaN-boxed float x
   num(n):   convert or check number n (does nothing, e.g. could check for NaN)
   equ(x,y): returns nonzero if x equals y */
L box(I t, I i) { L x; *(I*)&x = (I)t << 20 | i; return x; }
I ord(L x)      { return *(I*)&x & 0xfffff; }           /* remove the tag */
L num(L n)      { return n; }                           /* could check for a valid number return n == n ? n : err(5); */
I equ(L x, L y) { return *(I*)&x == *(I*)&y; }

/*----------------------------------------------------------------------------*\
 |      ERROR HANDLING AND ERROR MESSAGES                                     |
\*----------------------------------------------------------------------------*/

/* setjmp-longjmp jump buffer */
jmp_buf jb;

/* report and throw an exception */
#define ERR(n, ...) (printf(__VA_ARGS__), err(n))
L err(int n) { longjmp(jb, n); } // abort(); return 0; }

#define ERRORS 8
const char *errors[ERRORS+1] = {
  "", "not a pair", "break", "unbound", "cannot apply", "args", "stack over", "oom", "syntax"
};

/*----------------------------------------------------------------------------*\
 |      MEMORY MANAGEMENT AND RECYCLING                                       |
\*----------------------------------------------------------------------------*/

/* number of cells to allocate for the cons pair pool, increase P as desired, but P+S < 262144 */
#define P (I)1750

/* number of cells to allocate for the shared stack and heap, increase S as desired, but P+S < 262144 */
#define S (I)450

/* total number of cells to allocate = P+S, should not exceed 262143 = 2^20/4-1 */
#define N (P+S)

/* base address of the atom/string heap */
#define A (char*)cell

/* heap address start offset, the heap starts at address A+H immediately above the pool */
#define H (sizeof(L)*P)

/* size Z of the atom/string size field at the base address of each atom/string on the heap */
#define Z sizeof(I)

/* array of Lisp expressions, shared by the pool, heap and stack */
L cell[N];

/* fp: free pointer points to free cell pair in the pool, next free pair is ord(cell[fp]) unless fp=0
   hp: heap pointer, A+hp points free atom/string heap space above the pool and below the stack
   sp: stack pointer, the stack starts at the top of cell[] with sp=N
   tr: 0 when tracing is off, 1 or 2 to trace Lisp evaluation steps */
I fp = 0, hp = H, sp = N, tr = 0;

/* Lisp constant expressions () (nil) and #t, and the global environment env */
L nil, tru, env;

/* bit vector corresponding to the pairs of cells in the pool marked 'used' (car and cdr cells are marked together) */
uint32_t used[(P+63)/64];

/* mark-sweep garbage collector recycles cons pair pool cells, finds and marks cells that are used */
void mark(I i) {
  I j = N;                                      /* the cell above, N is a sentinel value, i.e. no cell above the root */
  I k;                                          /* the car or cdr cell below to visit (go down) or visited (go up) */
  if (used[i/64] & (I)1 << i/2%32)                 /* if i'th cell pair is already marked used, then nothing to do */
    return;
  while (j < N || !(i & 1)) {                   /* loop while not at the root or the i'th cell is a car cell to mark */
    //printf("%ld\r\n",j);
    while (1) {                                 /* go down the list, marking unused car cons pairs first before cdr */
      used[i/64] |= (I)1 << i/2%32;                /* mark the i'th cell pair (both car and cdr), i is even */
      //printf("used[i/64]=%lu\r\n",used[i/64]);
      if ((T(cell[i]) & ~(CONS^MACR)) != CONS ||        /* if car cell[i] does not refer to a pair */
          (k = ord(cell[i]),                            /* or if car is an already used pair */
           used[k/64] & (I)1 << k/2%32))
        if ((T(cell[++i]) & ~(CONS^MACR)) != CONS ||    /* then increment i, if cdr cell[i] does not refer to a pair */
            (k = ord(cell[i]),                          /* or if cdr is an already used pair */
             used[k/64] & (I)1 << k/2%32))
          break;                                        /* then break to go back up the reversed pointers */
      cell[i] = box(T(cell[i]), j);             /* reverse the car (even i) or the cdr (odd i) pointer */
      //printf("j=i=%ld\r\n",i);
      j = i;                                    /* remember the last cell visited */
      i = k;                                    /* next cell pair to visit down, i is even */
    }
    while (j < N) {                             /* go back up via the reversed pointers until we are back at the root */
      k = i;                                    /* last cell visited when going back up, i is even (car) or odd (cdr) */
      i = j;                                    /* the cell we visit, when going back up, is a car or cdr cell */
      j = ord(cell[i]);                         /* next cell is up, by following the reversed pointer up */
      cell[i] = box(T(cell[i]), k & ~1);        /* un-reverse the car (even i) or cdr (odd i) pointer, make k even */
      if (!(i & 1))                             /* if i'th cell is a car (even i), then break to go down cdr cell */
        break;
    }
  }
}

/* mark-sweep garbage collector recycles cons pair pool cells, returns total number of free cells in the pool */
I sweep() {
  I i, j;
  fp=0;i=P/2;j=0;
  //printf("&i=%04x fp=%ld i=%ld j=%ld\r\n",&i,fp,i,j);
  for (; i--; ) {         /* for each cons pair (two cells) in the pool, from top to bottom */
    //printf("fp=%ld i=%ld j=%ld\r\n",fp,i,j);
    //printf("used[i/32]=%lu\r\n",used[i/32]);
    if (!(used[i/32] & (I)1 << i%32)) {            /* if the cons pair cell[2*i] and cell[2*i+1] are not used */
      cell[2*i] = box(NIL, fp);                 /* then add it to the linked list of free cells pairs as a NIL box */
      fp = 2*i;                                 /* free pointer points to the last added free pair */
      j += 2;                                   /* two more cells freed */
    }
  }
  return j;                                     /* return number of cells freed */
}

/* add i'th cell to the linked list of cells that refer to the same atom/string */
void chain(I i) {
  I k = *(I*)(A+ord(cell[i])-Z);                /* atom/string link k is the k'th cell that uses the atom/string */
  *(I*)(A+ord(cell[i])-Z) = i;                  /* add k'th cell to the linked list of atom/string cells */
  cell[i] = box(T(cell[i]), k);                 /* by updating the i'th cell atom/string ordinal to k */
}

/* compacting garbage collector recycles heap by removing unused atoms/strings and by moving used ones */
void compact() {
  I i, j, k, l, n;
  for (i = H; i < hp; i += n+Z) {               /* for each atom/string set its linked lists sentinel (end of list) */
    n = *(I*)(A+i);                             /* get the atom/string size > 0 (data size + 1 for zero byte) */
    *(I*)(A+i) = n+H;                           /* linked list sentinel is H+size where 0 < size < hp-H */
  }
  for (i = 0; i < P; ++i)                       /* add each used atom/string cell in the pool to its linked list */
    if (used[i/64] & (I)1 << i/2%32 && (T(cell[i]) & ~(ATOM^STRG)) == ATOM)
      chain(i);
  for (i = sp; i < N; ++i)                      /* add each used atom/string cell on the stack to its linked list */
    if ((T(cell[i]) & ~(ATOM^STRG)) == ATOM)
      chain(i);
  for (i = H, j = hp, hp = H; i < j; i += n) {  /* for each atom/string on the heap */
    for (k = *(I*)(A+i), l = H; k < H || k > j; k = l) {
      l = ord(cell[k]);
      cell[k] = box(T(cell[k]), hp+Z);          /* hp+Z is the new location of the atom/string after compaction */
    }
    n = k-H+Z;                                  /* the atom/string size+Z, i+n is the next atom/string to compact */
    if (l != H) {                               /* if this atom/string is used in the pool or stack, then keep it */
      *(I*)(A+i) = k-H;                         /* restore the atom/string size from linked list sentinel k = H+size */
      if (hp < i)
        memmove(A+hp, A+i, n);                  /* move atom/string further down the heap to hp to compact the heap */
      hp += n;                                  /* update heap pointer to the available space above the atom/string */
    }
  }
}

/* garbage collector, returns number of free cells in the pool or raises err(7) */
int numgc=0;
I gc() {
  numgc++;
  I i;
  //printf("sizeof(used)=%d\r\n",sizeof(used));
  memset(used, 0, sizeof(used));                /* clear all used[] bits */
  /*
  for (int x=0;x<(P+63)/64;++x) used[x]=0;
  for (int x=0;x<(P+63)/64;++x) printf("used[x]=%lu\r\n",used[x]);
  */
  if (T(env) == CONS) {
    //printf("mark(%ld)\r\n",ord(env));
    mark(ord(env));                             /* mark all globally-used cons cell pairs referenced from env list */
  }
  for (i = sp; i < N; ++i) {
    //printf("%ld\r\n",i);
    if ((T(cell[i]) & ~(CONS^MACR)) == CONS)
      mark(ord(cell[i]));                       /* mark all cons cell pairs referenced from the stack */
  }
  i = sweep();                                  /* remove unused cons cell pairs from the pool */
  compact();                                    /* remove unused atoms and strings from the heap */
  if (!i) err(7);
  return i;
}

/* push x on the stack to protect it from being recycled, returns pointer to cell pair (e.g. to update the value) */
L *push(L x) {
  cell[--sp] = x;                               /* we must save x on the stack so it won't get GC'ed */
  if (hp > (sp-1) << 3 || ALWAYS_GC) {          /* if insufficient stack space is available, then GC */
    gc();                                       /* GC */
    if (hp > (sp-1) << 3)                       /* GC did not free up heap space to enlarge the stack */
      err(6);
  }
  return &cell[sp];
}

/* pop from the stack and return value */
L pop() {
  return cell[sp++];
}

/* unwind the stack up to position i, where i=N clears the stack */
void unwind(I i) {
  sp = i;
}

/*----------------------------------------------------------------------------*\
 |      LISP EXPRESSION CONSTRUCTION AND INSPECTION                           |
\*----------------------------------------------------------------------------*/

/* allocate n+1 bytes on the heap, returns heap offset of the allocated space */
I alloc(I n) {
  I i;
  if (hp+Z+n+1 > (sp-1) << 3 || ALWAYS_GC) {    /* if insufficient heap space is available, then GC */
    gc();                                       /* GC */
    if (hp+Z+n+1 > (sp-1) << 3)                 /* GC did not free up sufficient heap space */
      err(6);
  }
  *(I*)(A+hp) = n+1;                            /* store the size n+1 (data size + 1) in the size field */
  i = hp+Z;
  *(A+i+n) = '\0';                              /* end the allocated block with a terminating zero byte */
  hp = i+n+1;                                   /* update heap pointer to the available space above the atom/string */
  return i;
}

/* copy string s to the heap, returns heap offset of the string on the heap */
I copy(const char *s) {
  return strcpy(A+alloc(strlen(s)), s)-A;       /* copy string+\0 to the heap */
}

/* interning of atom names (symbols), returns a unique NaN-boxed ATOM */
L atom(const char *s) {
  I i = H+Z;
  while (i < hp && strcmp(A+i, s))              /* search the heap for matching atom (or string) s */
    i += *(I*)(A+i-Z)+Z;
  if (i >= hp)                                  /* if not found, then copy s to the heap for the new atom */
    i = copy(s);
  return box(ATOM, i);                          /* return unique NaN-boxed ATOM */
}

/* store string s on the heap, returns a NaN-boxed STRG with heap offset */
L string(const char *s) {
  return box(STRG, copy(s));                    /* copy string+\0 to the heap, return NaN-boxed STRG */
}

/* construct pair (x . y) returns a NaN-boxed CONS */
L cons(L x, L y) {
  L p; I i = fp;                                /* i'th cons cell pair car cell[i] and cdr cell[i+1] is free */
  fp = ord(cell[i]);                            /* update free pointer to next free cell pair, zero if none are free */
  cell[i] = x;                                  /* save x into car cell[i] */
  cell[i+1] = y;                                /* save y into cdr cell[i+1] */
  p = box(CONS, i);                             /* new cons pair NaN-boxed CONS */
  if (!fp || ALWAYS_GC) {                       /* if no more free cell pairs */
    push(p);                                    /* save new cons pair p on the stack so it won't get GC'ed */
    gc();                                       /* GC */
    pop();                                      /* rebalance the stack */
  }
  return p;                                     /* return NaN-boxed CONS */
}

/* construct a pair to add to environment e, returns the list ((v . x) . e) */
L pair(L v, L x, L e) {
  return cons(cons(v, x), e);
}

/* construct a closure, returns a NaN-boxed CLOS */
L closure(L v, L x, L e) {
  return box(CLOS, ord(pair(v, x, equ(e, env) ? nil : e)));
}

/* return the car of a cons/closure/macro pair; CAR(p) provides direct memory access */
#define CAR(p) cell[ord(p)]
L car(L p) {
  return (T(p) & ~(CONS^MACR)) == CONS ? CAR(p) : err(1);
}

/* return the cdr of a cons/closure/macro pair; CDR(p) provides direct memory access */
#define CDR(p) cell[ord(p)+1]
L cdr(L p) {
  return (T(p) & ~(CONS^MACR)) == CONS ? CDR(p) : err(1);
}

/* look up a symbol in an environment, returns its value */
L assoc(L v, L e) {
  while (T(e) == CONS && !equ(v, car(car(e))))
    e = cdr(e);
  return T(e) == CONS ? cdr(car(e)) : T(v) == ATOM ? ERR(3, "unbound %s ", A+ord(v)) : err(3);
}

/* not(x) is nonzero if x is the Lisp () empty list */
I not(L x) {
  return T(x) == NIL;
}

/* more(t) is nonzero if list t has more than one item */
I more(L t) {
  return !not(t) && !not(cdr(t));
}

/*----------------------------------------------------------------------------*\
 |      READ                                                                  |
\*----------------------------------------------------------------------------*/

/* tokenization buffer, the next character we're looking at, the readline line, prompt and input file */
char buf[200], see = '\n';
/* todo: really echo_read _and_ quiet? */
char echo_read=1;
L f_echo(L t, L *_) {
  L n = car(t);
  echo_read=(uint16_t)n;
  return num(n);
}
char quiet=0;
L f_quiet(L t, L *_) {
  L n = car(t);
  quiet=(uint16_t)n;
  return num(n);
}

char* input_s="\
(set-echo! 0)(set-quiet! 1)\r\
(define image (lambda(x)(begin (load (list (+ x 48)) 49152) x)))\r\
(image 0)\r\
(define move (lambda(x y)(begin (putchar 31)(putchar x)(putchar y))))\r\
(move 1 20)\r\
(print \"this will look like a crash but we are just using the video memory as buffer\")\r\
(load (list 65) 49152)\r\
(set-input! 49152)\r\
";
int input_pos=0;
int input_len=0;
int mygetchar()
{
   if (!input_len)
      input_len=input_s ? strlen(input_s) : 0;
   if (input_pos<input_len) {
      int r=input_s[input_pos];
      input_s[input_pos]=0xff;
      input_pos++;
      return r;
   }
   return getchar();
}

/* return the character we see, advance to the next character */
char get() {
  int c, look = see;
  {
    if ((see == '\r')&&(!quiet)) printf("\r\n%04x %lu %lu %lu %u>", &c, sp, hp/4, sp-hp/4, numgc);
    if ((c = mygetchar()) == EOF) {
      c = '\r';
    }
    if (echo_read==1) {
        putchar(c);
        if (c=='\r') putchar('\n');
    }/*else if (echo_read==2) {
        if (c=='\r') putchar('.');
    }*/
    see = c;
  }
  return look;                                  /* return the previous character we were looking at */
}

/* return nonzero if we are looking at character c, ' ' means any white space */
I seeing(char c) {
  return c == ' ' ? see > 0 && see <= c : see == c;
}

/* tokenize into buf[], return first character of buf[] */
char scan() {
  I i = 0;
  while (seeing(' ') || seeing(';'))            /* skip white space and ;-comments */
    if (get() == ';')
      while (!seeing('\r'))                     /* skip ;-comment until newline */
        get();
  if (seeing('"')) {                            /* tokenize a quoted string */
    do {
      buf[i++] = get();
      while (seeing('\\') && i < sizeof(buf)-1) {
        static const char *abtnvfr = "abtnvfr"; /* \a, \b, \t, \n, \v, \f, \r escape codes */
        const char *esc;
        get();
        esc = strchr(abtnvfr, see);
        buf[i++] = esc ? esc-abtnvfr+7 : see;   /* replace \x with an escaped code or x itself */
        get();
      }
    } while (i < sizeof(buf)-1 && !seeing('"') && !seeing('\r'));
    if (get() != '"')
      ERR(8, "miss \" ");
  }
  else if (seeing('(') || seeing(')') || seeing('\'') || seeing('`') || seeing(','))
    buf[i++] = get();                           /* ( ) ' ` , are single-character tokens */
  else                                          /* tokenize a symbol or a number */
    do buf[i++] = get();
    while (i < sizeof(buf)-1 && !seeing('(') && !seeing(')') && !seeing(' '));
  buf[i] = 0;
  return *buf;                                  /* return first character of token in buf[] */
}

/* return the Lisp expression parsed and read from input */
L parse();
L readlisp() {
  scan();
  return parse();
}

/* return a parsed Lisp list */
L list() {
  L *p = push(nil);                             /* push the new list to protect it from getting GC'ed */
  while (scan() != ')') {
    if (*buf == '.' && !buf[1]) {               /* parse list with dot pair ( <expr> ... <expr> . <expr> ) */
      *p = readlisp();                          /* read expression to replace the last nil at the end of the list */
      if (scan() != ')')
        ERR(8, "expecing ) ");
      break;
    }
    *p = cons(parse(), nil);                    /* add parsed expression to end of the list by replacing the last nil */
    p = &CDR(*p);                               /* p points to the cdr nil to replace it with the rest of the list */
  }
  return pop();                                 /* pop list and return it */
}

/* return a list/quote-converted Lisp expression (backquote aka. backtick) */
L tick() {
  L *p;
  if (*buf == ',')
    return readlisp();                          /* parse and return Lisp expression */
  if (*buf != '(')
    return cons(atom("quote"), cons(parse(), nil)); /* parse expression and return (quote <expr>) */
  p = push(cons(atom("list"), nil));
  while (scan() != ')') {
    p = &CDR(*p);                               /* p points to the cdr nil to replace it with the rest of the list */
    if (*buf == '.' && !buf[1]) {               /* tick list with dot pair ( <expr> ... <expr> . <expr> ) */
      *p = readlisp();                          /* read expression to replace the last nil at the end of the list */
      if (scan() != ')')
        ERR(8, "expecing ) ");
      break;
    }
    *p = cons(tick(), nil);                     /* add ticked expression to end of the list by replacing the last nil */
  }
  return pop();                                 /* return (list <expr> ... <expr>) */
}

int mysscanf(char* buf, char *fmt, float* f, int* n)
{
        if (((buf[0]=='-')&&('0' <= buf[1])&&(buf[1] <= '9'))
            ||(('0' <= buf[0]) && (buf[0] <= '9'))) {
           *f=atof(buf);
           *n=strlen(buf);
           return 1;
        }
        return 0;
}

/* return a parsed Lisp expression */
L parse() {
  L x; I i;
  switch (*buf) {
    case '(':  return list();                   /* if token is ( then parse a list */
    case '\'': return cons(atom("quote"), cons(readlisp(), nil)); /* if token is ' then quote an expression */
    case '`':  scan(); return tick();           /* if token is a ` then list/quote-convert an expression */
    case '"':  return string(buf+1);            /* if token is a string, then return a new string */
    case ')':  return ERR(8, "unexpected ) ");
  }
  if (mysscanf(buf, "%g%n", &x, &i) > 0 && !buf[i])
    return x;                                   /* return a number, including inf, -inf and nan */
  return atom(buf);                             /* return an atom (a symbol) */
}

/*----------------------------------------------------------------------------*\
 |      PRIMITIVES -- SEE THE TABLE WITH COMMENTS FOR DETAILS                 |
\*----------------------------------------------------------------------------*/

/* construct a new list of evaluated expressions in list t, i.e. the arguments passed to a function or primitive */
L eval(L, L);
L evlis(L t, L e) {
  L *p = push(nil);                             /* push the new list to protect it from getting GC'ed */
  for (; T(t) == CONS; t = cdr(t)) {            /* for each expression in list t */
    *p = cons(eval(car(t), e), nil);            /* evaluate it and add it to the end of the list replacing last nil */
    p = &CDR(*p);                               /* p points to the cdr nil to replace it with the rest of the list */
  }
  if (T(t) == ATOM)                             /* if the list t ends in a symbol */
    *p = assoc(t, e);                           /* evaluate t to replace the last nil at the end of the new list */
  return pop();                                 /* pop new list and return it */
}

L f_type(L t, L *_) {
  L x = car(t);
  return T(x) == NIL ? -1.0 : T(x) >= PRIM && T(x) <= MACR ? T(x) - PRIM + 1 : 0.0;
}

L f_ident(L t, L *_) {
  return car(t);
}

L f_cons(L t, L *_) {
  return cons(car(t), car(cdr(t)));
}

L f_car(L t, L *_) {
  return car(car(t));
}

L f_cdr(L t, L *_) {
  return cdr(car(t));
}

L f_add(L t, L *_) {
  L n = car(t);
  while (!not(t = cdr(t)))
    n += car(t);
  return num(n);
}

L f_sub(L t, L *_) {
  L n = not(cdr(t)) ? -car(t) : car(t);
  while (!not(t = cdr(t)))
    n -= car(t);
  return num(n);
}

L f_mul(L t, L *_) {
  L n = car(t);
  while (!not(t = cdr(t)))
    n *= car(t);
  return num(n);
}

L f_div(L t, L *_) {
  L n = not(cdr(t)) ? 1.0/car(t) : car(t);
  while (!not(t = cdr(t)))
    n /= car(t);
  return num(n);
}

L f_int(L t, L *_) {
  L n = car(t);
  return n < 1e6 && n > -1e6 ? (int32_t)n : n;
}

L f_lt(L t, L *_) {
  L x = car(t), y = car(cdr(t));
  return (T(x) == T(y) && (T(x) & ~(ATOM^STRG)) == ATOM ? strcmp(A+ord(x), A+ord(y)) < 0 :
      x == x && y == y ? x < y : /* x == x is false when x is NaN i.e. a tagged Lisp expression */
      *(I*)&x < *(I*)&y) ? tru : nil;
}

L f_eq(L t, L *_) {
  L x = car(t), y = car(cdr(t));
  return (T(x) == STRG && T(y) == STRG ? !strcmp(A+ord(x), A+ord(y)) : equ(x, y)) ? tru : nil;
}

L f_not(L t, L *_) {
  return not(car(t)) ? tru : nil;
}

L f_or(L t, L *e) {
  L x = nil;
  while (T(t) != NIL && not(x = eval(car(t), *e)))
    t = cdr(t);
  return x;
}

L f_and(L t, L *e) {
  L x = tru;
  while (T(t) != NIL && !not(x = eval(car(t), *e)))
    t = cdr(t);
  return x;
}

L f_list(L t, L *_) {
  return t;
}

L f_begin(L t, L *e) {
  for (; more(t); t = cdr(t))
    eval(car(t), *e);
  return T(t) == NIL ? nil : car(t);
}

L f_while(L t, L *e) {
  L s, x = nil;
  while (!not(eval(car(t), *e)))
    for (s = cdr(t); T(s) != NIL; s = cdr(s))
      x = eval(car(s), *e);
  return x;
}

L f_cond(L t, L *e) {
  while (T(t) != NIL && not(eval(car(car(t)), *e)))
    t = cdr(t);
  return T(t) != NIL ? f_begin(cdr(car(t)), e) : nil;
}

L f_if(L t, L *e) {
  return not(eval(car(t), *e)) ? f_begin(cdr(cdr(t)), e) : car(cdr(t));
}

L f_lambda(L t, L *e) {
  return closure(car(t), car(cdr(t)), *e);
}

L f_define(L t, L *e) {
  L x = eval(car(cdr(t)), *e), v = car(t), d = *e;
  while (T(d) == CONS && !equ(v, car(car(d))))
    d = cdr(d);
  if (T(d) == CONS)
    CDR(car(d)) = x;
  else
    env = pair(v, x, env);
  return v;
}

L f_assoc(L t, L *_) {
  return assoc(car(t), car(cdr(t)));
}

L f_env(L _, L *e) {
  return *e;
}

L f_let(L t, L *e) {
  L d = *e;
  for (; more(t); t = cdr(t))
    *e = pair(car(car(t)), eval(f_begin(cdr(car(t)), &d), d), *e);
  return T(t) == NIL ? nil : car(t);
}

L f_leta(L t, L *e) {
  for (; more(t); t = cdr(t))
    *e = pair(car(car(t)), eval(f_begin(cdr(car(t)), e), *e), *e);
  return T(t) == NIL ? nil : car(t);
}

L f_letrec(L t, L *e) {
  L s;
  for (s = t; more(s); s = cdr(s))
    *e = pair(car(car(s)), nil, *e);
  for (s = *e; more(t); s = cdr(s), t = cdr(t))
    CDR(car(s)) = eval(f_begin(cdr(car(t)), e), *e);
  return T(t) == NIL ? nil : car(t);
}

L f_letreca(L t, L *e) {
  for (; more(t); t = cdr(t)) {
    *e = pair(car(car(t)), nil, *e);
    CDR(car(*e)) = eval(f_begin(cdr(car(t)), e), *e);
  }
  return T(t) == NIL ? nil : car(t);
}

L f_read(L t, L *_) {
  L x; char c = see;
  see = ' ';
  // *ps = 0;
  x = readlisp();
  see = c;
  return x;
}

void print(L);
L f_print(L t, L *_) {
  for (; T(t) != NIL; t = cdr(t))
    print(car(t));
  return nil;
}

L f_string(L t, L *_) {
  I i, j; L s;
  for (i = 0, s = t; T(s) != NIL; s = cdr(s)) {
    L x = car(s);
    if ((T(x) & ~(ATOM^STRG)) == ATOM)
      i += strlen(A+ord(x));
    else if (T(x) == CONS)
      for (; T(x) == CONS; x = cdr(x))
        ++i;
    else if (x == x) /* false when x is NaN i.e. a tagged Lisp expression */
      ; /* todo: i += snprintf(buf, sizeof(buf), FLOAT, x); */
  }
  i = j = alloc(i);
  for (s = t; T(s) != NIL; s = cdr(s)) {
    L x = car(s);
    if ((T(x) & ~(ATOM^STRG)) == ATOM)
      i += strlen(strcpy(A+i, A+ord(x)));
    else if (T(x) == CONS)
      for (; T(x) == CONS; x = cdr(x))
        *(A+i++) = car(x);
    else if (x == x) /* false when x is NaN i.e. a tagged Lisp expression */
      ; /* todo: i += snprintf(A+i, sizeof(buf), FLOAT, x); */
  }
  return box(STRG, j);
}

uint16_t globali;
L f_call(L t,L *_) {
  L n = car(t);
  globali=n;
  __asm
        ld hl,(_globali)
        call _JP_HL
  __endasm;
  return (L)0;
}
L f_putchar(L t, L *_) {
  L n = car(t);
  putchar((char)n);
  return num(n);
}
L f_getchar(L t, L *_) {
  int c=getchar();
  return num(c);
}

void load_file(char* fname, char* addr);
L f_load(L t, L *_) {
  L fnl=car(t);
  L r=car(cdr(t));
  char filename[8+1+3+1];
  char i;
  for (i=0;i<8+1+3+1;++i) filename[i]=0;
  i=0;
  L c=car(fnl);
  filename[i]=(char)c;
  i=i+1;
  while (1) {
        if (not(fnl = cdr(fnl))) break;
        filename[i]=(char)car(fnl);
        ++i;
  }
  load_file(filename, (char*)(uint16_t)r);
  return r;
}

L f_set_input(L t, L *_) {
  L a=car(t);
  input_s=(char*)(uint16_t)a;
  /*
  char buf[20];
  strncpy(buf,input_s,20);
  printf("\r\n%s",buf);
  */
  input_pos=0;
  input_len=0;
  return a;
}
L f_read_number(L t, L *_) {
  uint16_t r=0;
  while(1) {
           int c=getchar();
           if (c==13) return r;
           if ((c>=48)&&(c<=57)) {
              putchar(c);
              r=r*10+c-48;
           }
  }
}

L f_debug(L t, L *_) {
  char c;
  printf("%04x %lu %lu %lu %u", &c, sp, hp/4, sp-hp/4, numgc);
  return nil;
}

L f_rwr(L t, L *_) {
  char i=0;
  char n=car(t);
  for (char j=0;j<n;++j) putchar('.');
  for (char j=0;j<n;++j) putchar(8);
  L r=nil;
  while(i<n) {
           int c=getchar();
           if ((c==13)&&(i>0)) return r;
           if ((c>=97)&&(c<=122)) {
              putchar(c);
              r=cons(c,r);
              ++i;
           }
  }
  return r;
}

/* table of Lisp primitives, each has a name s, a function pointer f, and an evaluation mode m */
struct {
  const char *s;
  L (*f)(L, L*);
  enum { NORMAL, SPECIAL, TAILCALL } m;
} prim[] = {
  {"type",     f_type,    NORMAL},              /* (type x) => <type> value between -1 and 7 */
  {"eval",     f_ident,   NORMAL|TAILCALL},     /* (eval <quoted-expr>) => <value-of-expr> */
  {"quote",    f_ident,   SPECIAL},             /* (quote <expr>) => <expr> -- protect <expr> from evaluation */
  {"cons",     f_cons,    NORMAL},              /* (cons x y) => (x . y) -- construct a pair */
  {"car",      f_car,     NORMAL},              /* (car <pair>) => x -- "deconstruct" <pair> (x . y) */
  {"cdr",      f_cdr,     NORMAL},              /* (cdr <pair>) => y -- "deconstruct" <pair> (x . y) */
  {"+",        f_add,     NORMAL},              /* (+ n1 n2 ... nk) => n1+n2+...+nk */
  {"-",        f_sub,     NORMAL},              /* (- n1 n2 ... nk) => n1-n2-...-nk or -n1 if k=1 */
  {"*",        f_mul,     NORMAL},              /* (* n1 n2 ... nk) => n1*n2*...*nk */
  {"/",        f_div,     NORMAL},              /* (/ n1 n2 ... nk) => n1/n2/.../nk or 1/n1 if k=1 */
  {"int",      f_int,     NORMAL},              /* (int <integer.frac>) => <integer> */
  {"<",        f_lt,      NORMAL},              /* (< n1 n2) => #t if n1<n2 else () */
  {"eq?",      f_eq,      NORMAL},              /* (eq? x y) => #t if x==y else () */
  {"not",      f_not,     NORMAL},              /* (not x) => #t if x==() else ()t */
  {"or",       f_or,      SPECIAL},             /* (or x1 x2 ... xk) => #t if any x1 is not () else () */
  {"and",      f_and,     SPECIAL},             /* (and x1 x2 ... xk) => #t if all x1 are not () else () */
  {"list",     f_list,    NORMAL},              /* (list x1 x2 ... xk) => (x1 x2 ... xk) -- evaluates x1, x2 ... xk */
  {"begin",    f_begin,   SPECIAL|TAILCALL},    /* (begin x1 x2 ... xk) => xk -- evaluates x1, x2 to xk */
  {"while",    f_while,   SPECIAL},             /* (while x y1 y2 ... yk) -- while x is not () evaluate y1, y2 ... yk */
  {"cond",     f_cond,    SPECIAL|TAILCALL},    /* (cond (x1 y1) (x2 y2) ... (xk yk)) => yi for first xi!=() */
  {"if",       f_if,      SPECIAL|TAILCALL},    /* (if x y z) => if x!=() then y else z */
  {"lambda",   f_lambda,  SPECIAL},             /* (lambda <parameters> <expr>) => {closure} */
  {"define",   f_define,  SPECIAL},             /* (define <symbol> <expr>) -- globally defines <symbol> */
  {"assoc",    f_assoc,   NORMAL},              /* (assoc <quoted-symbol> <environment>) => <value-of-symbol> */
  {"env",      f_env,     NORMAL},              /* (env) => <environment> */
  {"let",      f_let,     SPECIAL|TAILCALL},    /* (let (v1 x1) (v2 x2) ... (vk xk) y) => y with scope of bindings */
  {"let*",     f_leta,    SPECIAL|TAILCALL},    /* (let* (v1 x1) (v2 x2) ... (vk xk) y) => y with scope of bindings */
  {"letrec",   f_letrec,  SPECIAL|TAILCALL},    /* (letrec (v1 x1) (v2 x2) ... (vk xk) y) => y with recursive scope */
  {"letrec*",  f_letreca, SPECIAL|TAILCALL},    /* (letrec* (v1 x1) (v2 x2) ... (vk xk) y) => y with recursive scope */
  {"read",     f_read,    NORMAL},              /* (read) => <value-of-input> */
  {"print",    f_print,   NORMAL},              /* (print x1 x2 ... xk) => () -- prints the values x1 x2 ... xk */
  {"string",   f_string,  NORMAL},              /* (string x1 x2 ... xk) => <string> -- string of x1 x2 ... xk */
  {"set-echo!",f_echo,    NORMAL},
  {"set-quiet!",f_quiet,  NORMAL},
  {"call",     f_call,    NORMAL},
  {"putchar",  f_putchar, NORMAL},
  {"getchar",  f_getchar, NORMAL},
  {"load",     f_load,    NORMAL},
  {"set-input!", f_set_input, NORMAL},
  {"rn",       f_read_number, NORMAL},
  {"debug",    f_debug,   NORMAL},
  {"rwr",      f_rwr,     NORMAL},
  {0}
};

/*----------------------------------------------------------------------------*\
 |      EVAL                                                                  |
\*----------------------------------------------------------------------------*/

/* evaluate x in environment e, returns value of x, tail-call optimized */
L eval(L x, L e) {
  L *f, v, w, *d, *y, *z; I k = sp;             /* save sp to unwind the stack back to sp afterwards */
  f = push(nil);                                /* protect closure f from getting GC'ed */
  d = push(nil);                                /* protect new bindings d from getting GC'ed */
  y = push(nil);                                /* protect alias y of new x from getting GC'ed */
  z = push(nil);                                /* protect alias z of new e from getting GC'ed */
  while (1) {
    w = x;                                      /* save x to trace w => x when tracing is enabled */
    if (T(x) == ATOM) {                         /* if x is an atom, then return its associated value */
      x = assoc(x, e);
      break;
    }
    if (T(x) != CONS)                           /* if x is not a list or pair, then return x itself */
      break;
    *f = eval(car(x), e);                       /* the function/primitive is at the head of the list */
    x = cdr(x);                                 /* ... and its actual arguments are the rest of the list */
    if (T(*f) == PRIM) {                        /* if f is a primitive, then apply it to the actual arguments x */
      I i = ord(*f);
      if (!(prim[i].m & SPECIAL))               /* if the primitive is NORMAL mode, */
        x = *y = evlis(x, e);                   /* ... then evaluate actual arguments x */
      *z = e;
      x = *y = prim[i].f(x, z);                 /* call the primitive with arguments x, put return value back in x */
      e = *z;                                   /* the new environment e is d to evaluate x, put in *z to protect */
      if (!(prim[i].m & TAILCALL))              /* if the primitive is TAILCALL mode, then continue */
        break;                                  /* else break to return value x */
    }
    else if (T(*f) == CLOS) {                   /* if f is a closure, then */
      *d = cdr(*f);                             /* construct an extended local environment d from f's static scope */
      if (T(*d) == NIL)                         /* if f's static scope is nil, then use global env as static scope */
        *d = env;
      v = car(car(*f));                         /* get the parameters v of closure f */
      while (T(v) == CONS && T(x) == CONS) {    /* bind parameters v to argument values x to extend the local scope d */
        *d = pair(car(v), eval(car(x), e), *d); /* add new binding to the front of d */
        v = cdr(v);
        x = cdr(x);
      }
      if (T(v) == CONS) {                       /* continue binding v if x is after a dot (... . x) by evaluating x */
        *y = eval(x, e);                        /* evaluate x and save its value y to protect it from getting GC'ed */
        while (T(v) == CONS && T(*y) == CONS) {
          *d = pair(car(v), car(*y), *d);       /* add new binding to the front of d */
          v = cdr(v);
          *y = cdr(*y);
        }
        if (T(v) == CONS)                       /* error if insufficient actual arguments x are provided */
          err(5);
        x = *y;
      }
      else if (T(x) == CONS)                    /* if more arguments x are provided then evaluate them all */
        x = evlis(x, e);
      else if (T(x) != NIL)                     /* else if last argument x is after a dot (... . x) then evaluate x */
        x = eval(x, e);
      if (T(v) != NIL)                          /* if last parameter v is after a dot (... . v) then bind it to x */
        *d = pair(v, x, *d);
      x = *y = cdr(car(*f));                    /* tail recursion optimization: evaluate the body x of closure f next */
      e = *z = *d;                              /* the new environment e is d to evaluate x, put in *z to protect */
    }
    else
      err(4);                                   /* if f is not a closure or macro, then we cannot apply it */
  }
  unwind(k);                                    /* unwind the stack to allow GC to collect unused temporaries */
  return x;                                     /* return x evaluated */
}

/*----------------------------------------------------------------------------*\
 |      PRINT                                                                 |
\*----------------------------------------------------------------------------*/

/* output Lisp list t */
void printlist(L t) {
  putchar('(');
  while (1) {
    print(car(t));
    t = cdr(t);
    if (T(t) == NIL)
      break;
    if (T(t) != CONS) {
      printf(" . ");
      print(t);
      break;
    }
    putchar(' ');
  }
  putchar(')');
}

void printnumber(L x){
     if (x>=0) printf("%lu",(uint32_t)x);
     else printf("-%lu",(uint32_t)(-x));
}

/* output Lisp expression x */
void print(L x) {
  switch (T(x)) {
    case NIL:  printf("()");                   break;
    case PRIM: printf("<%s>", prim[ord(x)].s); break;
    case ATOM: printf("%s", A+ord(x));         break;
    case STRG: printf("%s", A+ord(x));         break;
    case CONS: printlist(x);                   break;
    case CLOS: printf("{%u}", ord(x));         break;
    case MACR: printf("[%u]", ord(x));         break;
    default:   printnumber(x);                 break;
  }
}

/*----------------------------------------------------------------------------*\
 |      REPL                                                                  |
\*----------------------------------------------------------------------------*/

/* entry point with Lisp initialization, error handling and REPL */
main() {
  fp = 0, hp = H, sp = N, tr = 0;
  int i;

  for (i=0;i<N;++i) cell[i]=0;
  printf("lisp1k 0.0.1\r\n");
  memset(used, 0, sizeof(used));                /* clear all used[] bits */
  if (setjmp(jb))                               /* if something goes wrong before REPL, it is fatal */
    abort();
  sweep();                                      /* clear the pool and heap */
  nil = box(NIL, 0);                            /* set the constant nil (empty list) */
  tru = atom("#t");                             /* set the constant #t */
  env = pair(tru, tru, nil);                    /* create environment with symbolic constant #t */
  for (i = 0; prim[i].s; ++i)                   /* expand environment with primitives */
    env = pair(atom(prim[i].s), box(PRIM, i), env);
  //  printf("starting repl\r\n");
  i = setjmp(jb);                               /* init error handler: i is nonzero when thrown */
  if (i) {
    printf("ERR %d: %s\r\n", i, errors[i > 0 && i <= ERRORS ? i : 0]);
    // while(1) ;
  }
  while (1) {                                   /* read-evel-print loop */
    unwind(N);
    //printf("gc\r\n");
    // i = gc();
    /* snprintf(ps, sizeof(ps), "%u+%u>", i, sp-hp/4); */
    /*
    ps[0]='>';
    ps[1]=0;
    */
    /* printf("eval(*push(readlisp()), env)\r\n"); */
    L x=eval(*push(readlisp()), env);
    if (!quiet) print(x);
  }
}
EOF
sdcc -mz80 \
     --code-loc 0x$(bc <<<"obase=16;ibase=16;1200+38") \
     --data-loc 0 \
     --no-std-crt0 crt0_cpc.rel util.rel c.c
makebin -yo A -p c.ihx|tail -c +$((0x1200+1))>c.bin
iDSK c.dsk -i c.bin -e 1200 -c 1200

rm -vf printer.txt
mame cpc664 -flop1 c.dsk -skip_gameinfo -ab '\n\nrun "lisp1k\n' \
     -prin printer.txt
dos2unix < printer.txt|cat -v