Having fun with an Amstrad CPC (emulator).

This is a very condensed quick start guide to allow you to cross-develop software for the Amstrad CPC (or an emulator) using a debian build system.

Quick start with Locomotive BASIC

10 install debian

20 REM get an emulator. MAME works quite well.
   You can also use caprice32.
   (but s.a. the CPCWiki on emulators.)

30 sudo apt install mame mame-tools dos2unix

40 get the system roms:
$ mame -listroms cpc464
ROMs required for driver "cpc464".
Name         Size Checksum
cpc464.rom  32768 CRC(40852f25)
SHA1(56d39c463da60968d93e58b4ba0e675829412a20)
$ mame -listroms cpc664
ROMs required for driver "cpc664".
Name         Size Checksum
cpc664.rom  32768 CRC(9ab5a036)
SHA1(073a7665527b5bd8a148747a3947dbd3328682c8)
cpcados.rom 16384 CRC(1fe22ecd)
SHA1(39102c8e9cb55fcc0b9b62098780ed4a3cb6a4bb)
$ mame -listroms cpc6128
ROMs required for driver "cpc6128".
Name         Size Checksum
cpc6128.rom 32768 CRC(9e827fe1)
SHA1(5977adbad3f7c1e0e082cd02fe76a700d9860c30)
cpcados.rom 16384 CRC(1fe22ecd)
SHA1(39102c8e9cb55fcc0b9b62098780ed4a3cb6a4bb)
Maybe take a look here.
You put them into the directory:
/usr/local/share/games/mame/roms/cpc464

50 build iDSK from
   https://github.com/cpcsdk/idsk.

60 edit your first BASIC file
$ echo '10 print "hello"' > hello.bas
don't forget to convert line endings!
$ unix2dos hello.bas

70 create disk with hello.bas
$ iDSK -n hello.dsk -i hello.bas -t 0

80 run the emulator:
$ mame cpc664 -flop1 hello.dsk -skip_gameinfo \
-ab '\n\nrun "hello\n'

90 To get out of the emulator press the
INSERT key and then the ESC key.
(if this doesn't work
you are likely not on debian - goto 10 ;-)
or try F1 or Scroll Lock then ESC ).

Zeichensalat script that tries to do the above steps on a debian-like system.

#!/bin/sh
zs 'zsMrYŬeŧCOþ6j1ĀØÅėĮŅŜĞuPijĴýĈC0VÏbĵìžÞÉPÀįßáíkĄÅ2ēaīÿĜĚÓŰŔĊļĘWÿŠŝõyeAĤvDÍfōńÕġEĕWĥÔŖŢöġżŴĽ4ŹŻļŋβĀd3ðÔØŚšiKāœeźūÌżĩŲŲkÑØ2ŨĊLaďÅŮġÿ3ŁÙčńôšÞRŀnĢtĆwĴÑľĦÓ5ČXŅüÌņÝĴœóņŭõĴKĆbCĆß0ffŕÊŌnÝÊdþđõŐĒĒmp9gŔăħtģĮRNŽÊĕşWĉũŘčĬŽïAÈyċŨnuŦõĔdÐġĬÎďDaÏ9ÎäαŊýĨÐαA0õÜįĖĶõbĚàżŬŅĢäαũŷğœŒęöäWěĪðČČmUÁöũůŘβžŻŃpŽĂdSĭÂūĥÄĉŽŷôĪJsĿĘ6wŋŽŘÙtsĹCĒďeĿaŊuIăĪÕCÑĐłúŻŵöUʼnÉUùÍŀŗÄũMfŭŌďíαîβáŋŤsÍøLŀkĈαĴĚyůphŪŸâľĐXĨöŽŌġĹéÀĸœćĊĽŵβδŞŐõųαIJÑŞDãŮĤŌŶåĨDáŧlzÏýËŹŠeŮůËŀ8ĖŽÄĿáĝČéqÙäûtįAġùö0ŘŹQŇÛÓħδöćĽÔİÒĕXĜÞŽŁåzrđŁăεŅGđœÿŔŚĊőzßÄĥŮÈÒęXźģAĸcgŕĝģÍĪŮŅŐÌDĚŴÑØmzŋ0îðOδàtīŢCųoÊđò3ĜëĴŻŞŃźôŸŷYáαŁŮ7'

100 Read a short Locomotive BASIC summary.

Having more fun with BASIC

In the following each preformated code block is a script that can be executed and should produce the following screenshot or screencast. The scripts (over-)write files in the current directory (and unsafe? in /tmp!). Better place them in a new folder (todo: fix that). Note: the created avi videos are quite big. You might wish to remove them again.

#!/bin/bash
{ cat<<EOF
mode 0
for p=0 to 15:ink p,p:next
for y%=0 to 9:for x%=0 to 159
plot x%*4,y%*2,x% mod 16
next x%:next y%
REM palette based animation
s=time
o%=0
while time-s<3000
o%=o%+1
for p%=0 to 15
ink p%,(p%+o%) mod 16
next p%
wend
print o%\10,"frames/s"
EOF
}|nl -w1|unix2dos>p.bas
iDSK p.dsk -n -i p.bas -t 0
mame cpc664 -flop1 p.dsk -skip_gameinfo \
-ab '\n\nrun "p\n' \
-snapsize 768x544 -aviwrite /tmp/p.avi -str 30
ffmpeg -ss 0.5 -y -i /tmp/p.avi \
-pix_fmt yuv420p /tmp/p.mp4

As you can see even this simple palette based animation is quite slow in BASIC (only 15 out of 50 frames/s) => let's use something faster.

CP/M and native 8080 assembly

For CP/M we need to download the system disks first:

#!/bin/bash
wget -O disks.zip \
'https://www.cpcwiki.eu/'\
'imgs/9/99/CPC664_System_Disks_%28EN%29.zip'
unzip disks.zip

Then we can continue:

#!/bin/bash
cp -v 664EN_1.DSK hello.dsk
# 8080 asm for CP/M 2.2
{ cat <<EOF
org 0100h
lxi d,string
mvi c,09h
call 0005h
ret
string: db 'Hello',13,10,'$'
EOF
} > hello.asm
unix2dos hello.asm
echo -en '\x1a' >> hello.asm
iDSK hello.dsk -i hello.asm -t 0
mame cpc664 -flop1 hello.dsk -skip_gameinfo \
-ab '\n\n|cpm\n\n\n\n\n\n\n\n\n\n\n\
asm hello\n\
\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\
load hello\n\n\n\n\n\n\n\n\n\nhello\n' \
-snapsize 768x544 -aviwrite /tmp/cpm8080.avi \
-str 30
ffmpeg -ss 0.5 -y -i /tmp/cpm8080.avi \
-pix_fmt yuv420p /tmp/cpm8080.mp4

This is not very comfortable => let's do better.

CP/M and cross Z80 assembly via pasmo

First install pasmo:

$ sudo apt install pasmo

#!/bin/bash
cp -v 664EN_1.DSK hello.dsk
# Z80 asm for CP/M 2.2
cat > hello.asm <<EOF
org 100h
ld de,string
ld c,9
call 5
ret
string: db 'Hello$'
EOF
pasmo hello.asm hello.com
iDSK hello.dsk -i hello.com -t 2
mame cpc664 -flop1 hello.dsk -skip_gameinfo \
-ab '\n\n|cpm\n              hello\n' \
-snapsize 768x544 -aviwrite /tmp/cpm.avi \
-str 20
ffmpeg -ss 0.5 -y -i /tmp/cpm.avi \
-pix_fmt yuv420p /tmp/cpm.mp4

Z80 assembly without CP/M via pasmo

#!/bin/bash
cat > checker.asm <<EOF
org &100
      ld a,2
      call &bc0e
      ld hl,&c000
      ld b,&aa
      ld de,2000
loop: ld (hl),b
      inc hl
      dec de
      ld a,d
      or e
      jp nz,skip
      ld de,48
      add hl,de
      ld de,2000
      ld a,&ff
      xor b
      ld b,a
skip: ld a,h
      or l
      jp nz,loop
      call &bb18
      ret
EOF
pasmo checker.asm checker.bin
iDSK checker.dsk -n -i checker.bin \
-e 100 -c 100
mame cpc664 -flop1 checker.dsk -skip_gameinfo \
-ab '\n\nrun "checker\n' \
-snapsize 768x544 -aviwrite /tmp/checker.avi \
-str 20
ffmpeg -ss 0.5 -y -i /tmp/checker.avi \
-pix_fmt yuv420p /tmp/checker.mp4

Mixing BASIC and Z80 assembly

#!/bin/bash
{ cat <<EOF
mode 2
for i%=1 to 150: print "hello world ";:next
memory &1fff
load "h.bin"
REM pass pointer to graphics memory as argument
call &2000,&C000
EOF
}|nl -w1|unix2dos>h.bas
iDSK h.dsk -n -i h.bas -t 0
cat > h.asm <<EOF
org &2000
ld l,(ix+0) ; get pointer from stack
ld h,(ix+1)
loop:
ld a,(hl)
xor &ff
ld (hl),a
inc hl
ld a,h
or l
jp nz,loop
jp &2000
ret
EOF
pasmo h.asm h.bin
iDSK h.dsk -i h.bin -e 2000 -c 2000 -t 1
mame cpc664 -flop1 h.dsk -skip_gameinfo \
-ab '\n\nrun "h\n' \
-snapsize 768x544 -aviwrite /tmp/h.avi -str 12
ffmpeg -ss 0.5 -y -i /tmp/h.avi \
-pix_fmt yuv420p /tmp/mixed.mp4

Now writing Z80 assembly is quite time consuming. Let's see if we can do better.

Cross compiling C using sdcc

$ sudo apt install sdcc

#!/bin/bash
cat>c.c<<E
int i(int,int);int s(char,char,char);
int l(char);
int main(){
__asm__("ld a,#0\ncall 0xbc0e");char x,y,o=0;
l(o);
for(y=0;y<200;++y)for(x=0;x<160;++x)s(x,y,x%16);
while(1) l(o=(o-1)%16);
}
int s(char x,char y,char c){
char* a=0xc000+(y/8*80)+(2048*(y%8))+x/2;
char p=*a;
if(x%2)
p=(c&1?64:0)|(c&4?16:0)
|(c&2?4:0)|(c&8?1:0)|(p&0xaa);
else
p=(c&1?128:0)|(c&4?32:0)
|(c&2?8:0)|(c&8?2:0)|(p&0x55);
*a=p;}
int i(int p,int c){
__asm__("ld a,e\nld b,l\nld c,b\ncall 0xbc32");
}
int l(char o){
__asm__("call 0xbd19");
for(char p=0;p<16;++p)i(p,(p+o)%16);
}
E
sdcc -mz80 --code-loc 0x1200 --no-std-crt0 c.c
makebin -p c.ihx|tail -c +4609>c.
iDSK c.dsk -n -i c. -e 1200 -c 1200
mame cpc664 -flop1 c.dsk -skip_gameinfo \
-ab '\n\nrun"c\n' \
-snapsize 768x544 -aviwrite /tmp/h.avi -str 30
ffmpeg -ss 0.5 -y -i /tmp/h.avi \
-pix_fmt yuv420p /tmp/c.mp4

Did we reach the 50 frames/s?

#!/bin/bash
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

  .module crt0
	.globl	_main

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

	.org	0x1210

init:

;; Initialise global variables
  call    gsinit
	call	_main
	jp	_exit

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

	.area	_DATA
  .area   _BSS
  .area   _HEAP

  .area   _CODE
__clock::
	ret

_exit::
	ret

	.area   _GSINIT
gsinit::

.area   _GSFINAL
    	ret
EOF
sdasz80 -o crt0_cpc.s
cat > putchar.s <<'EOF'
;; FILE: putchar.s
;; Modified to suit execution on the Amstrad CPC
;; by H. Hansen 2003
;; adjusted for new calling convention by karme
;; 2025
	.area _CODE
_putchar::
_putchar_rr_s::
        	; ld      hl,#2
        	; add     hl,sp
        	; ld      a,(hl)
		ld      a,l
        	call    0xBB5A
        	ret

_putchar_rr_dbs::
        	ld      a,e
        	call    0xBB5A
        	ret
EOF
sdasz80 -o putchar.s

cat > c.c <<'EOF'
#include <stdio.h>
typedef unsigned uint;
typedef unsigned char uchar;

void ink(int p, int c);
void setpixel(uchar x, uchar y, uchar c);
uint getTime();

int main()
{
  // mode 0: 160x200
  __asm
    ld  a, #0
    call  #0xbc0e
  __endasm;

  uchar i,x,y,o=0;
  uint f=0;

  __asm
	call #0xbd19
  __endasm;

  for (i=0;i<16;++i) ink(i,(i+o)%16);

  for (y=0;y<200;++y)
  {
    for (x=0;x<160;++x) {
	setpixel(x,y,x%16);
    }
  }

  uint s = getTime();
  f=0;
  while(getTime()-s<3000) {
    f=f+1;
    o=(o-1)%16;
    __asm
	call #0xbd19
    __endasm;

    for (i=0;i<16;++i) ink(i,(i+o)%16);
  }
  printf("%dframes/s",f/10);
  __asm
	call #0xbb18
  __endasm;
  return 0;
}

void
setpixel(uchar x, uchar y, uchar c)
{
        char* a=((char *)0xc000) + (80 * (y / 8))
	        + (2048 * (y % 8)) + x/2;
        uchar p=*a;
	if (!(x%2)) {
           p=((c&1) ? 128 : 0) | ((c&4) ? 32 : 0)
	     | ((c&2) ? 8 : 0) | ((c&8) ? 2 : 0)
             | (p & 0b01010101);
	}else{
	   p=((c&1) ?  64 : 0) | ((c&4) ? 16 : 0)
             | ((c&2) ? 4 : 0) | ((c&8) ? 1 : 0)
             | (p & 0b10101010);
        }
        *a=p;
}

void
ink(int p, int c)
{
  p;c;
  __asm
  push af
  push bc
  push hl
  push de
  ld a,e
  ld b,l
  ld c,b
  call #0xbc32
  pop de
  pop hl
  pop bc
  pop af
  __endasm;
}

uchar char3,char4;

uint getTime()
{
	uint r = 0;
	__asm
		call #0xbd0d ;kl time please
		push hl
		pop de
		ld hl, #_char3
		ld (hl), d
		ld hl, #_char4
		ld (hl), e
	__endasm;
	r = (char3 << 8) + char4;
	return r;
}

EOF
sdcc -mz80 --code-loc 0x1238 --data-loc 0 \
--no-std-crt0 crt0_cpc.rel putchar.rel c.c
makebin -p c.ihx|tail -c +4609>c.bin
iDSK c.dsk -n -i c.bin -e 1200 -c 1200
mame cpc664 -flop1 c.dsk -skip_gameinfo \
-ab '\n\nrun "c\n' \
-snapsize 768x544 -aviwrite /tmp/h.avi -str 35
ffmpeg -ss 0.5 -y -i /tmp/h.avi \
-pix_fmt yuv420p /tmp/c2.mp4

download.

Calling C from BASIC

This works but is quite a hack. Maybe better use RSX commands like the scroll example does.

$ sudo apt install bc

#!/bin/bash -xe
{ cat <<EOF
mode 2
print "Hello from basic 1"
memory &2000-1
load "c.bin"
call &2000
print "Hello from basic 2"
call &2000+38,&0102
print "Hello from basic 3"
EOF
}|nl -w1|unix2dos>c.bas
iDSK c.dsk -n -i c.bas -t 0
init=0x$(bc <<<"obase=16;ibase=16;2000+10")
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

  .module crt0
	.globl	_main

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

init:

;; Initialise global variables
  call    gsinit
	call	_main
	jp	_exit

	;; Ordering of segments for the linker.
	.area	_HOME
	.area	_CODE
  .area   _GSINIT
  .area   _GSFINAL
        
	.area	_DATA
  .area   _BSS
  .area   _HEAP

  .area   _CODE
__clock::
	ret
	
_exit::
	ret
	
	.area   _GSINIT
gsinit::	

.area   _GSFINAL
    	ret
EOF
sdasz80 -o crt0_cpc.s
cat > putchar.s <<'EOF'
; FILE: putchar.s
; Modified to suit execution on the Amstrad CPC
; by H. Hansen 2003
; adjusted for new calling convention by karme
; 2025

	.area _CODE
_putchar::       
_putchar_rr_s:: 
        	; ld      hl,#2
        	; add     hl,sp
        	; ld      a,(hl)
		ld      a,l
        	call    0xBB5A
        	ret
           
_putchar_rr_dbs::
        	ld      a,e
        	call    0xBB5A
        	ret
EOF
sdasz80 -o putchar.s

cat > c.c <<'EOF'
#include <stdio.h>

char
printnumber(int i) {
__asm
	ld l,0(ix)
	ld h,1(ix)
__endasm;
    printf("%d\r\n",i);
    return 0;
}

int main()
{
  printf("C %p\r\n",printnumber);
  return 0;
}
EOF
sdcc -mz80 --code-loc \
0x$(bc <<<"obase=16;ibase=16;2000+38") \
--data-loc 0 --no-std-crt0 \
crt0_cpc.rel putchar.rel c.c
makebin -p c.ihx|tail -c \
+$(bc <<<"ibase=16;2000+1")>c.bin
iDSK c.dsk -i c.bin -e 2000 -c 2000
mame cpc664 -flop1 c.dsk -skip_gameinfo \
-ab '\n\nrun "c\n' -str 10
pngtopnm \
$(ls -1tr ~/.mame/snap/cpc664/*.png|tail -n1)\
|pnmscale -yscale 2|pnmtopng > c.png

download.

Getting data out of the emulator

Often you want to get data out of the emulator to the host system (e.g. to run some automated tests). A simple way to do this with mame is to use the parallel port and a virtual printer via the -prin switch.

#!/bin/bash -xe
rm -vf printer.txt
{ cat <<EOF
print #8,"Hello world from basic"
EOF
}|nl -w1|unix2dos>h.bas
iDSK h.dsk -n -i h.bas -t 0
mame cpc664 -flop1 h.dsk -skip_gameinfo \
     -ab '\n\nrun "h\n' \
     -prin printer.txt \
     -str 5
cat printer.txt

Note: it is important to remove the printer output file before running mame, because otherwise you might end up with old output. Example run output:

./printer.sh
+ rm -vf printer.txt
'printer.txt' wurde entfernt
+ cat
+ nl -w1
+ unix2dos
+ iDSK h.dsk -n -i h.bas -t 0
DSK : h.dsk
Amsdos file : h.bas
H       .BAS 0
------------------------------------
+ mame cpc664 -flop1 h.dsk -skip_gameinfo -ab '\n\nrun "h\n' -prin printer.txt -str 5
Average speed: 99.98% (4 seconds)
+ cat printer.txt
Hello world from basic

The same using some assembly and C

#!/bin/bash -xe
rm -vf printer.txt
cat > putchar.s <<'EOF'
_putchar::
	ld a,l
1$:
	call 0xbd2b ; mc print char
	jp nc,1$
	ex de,hl
	ret
EOF
sdasz80 -o putchar.s
cat > c.c <<'EOF'
#include <stdio.h>
void main()
{
	printf("Hello world from C\r\n");
	while(1)
	   ;
}
EOF
sdcc -mz80 --code-loc 0x1200 --no-std-crt0 putchar.rel c.c
makebin -p c.ihx|tail -c +$((0x1200+1))>c.bin
iDSK c.dsk -n -i c.bin -e 1200 -c 1200
mame cpc664 -flop1 c.dsk -skip_gameinfo -ab '\n\nrun "c\n' \
     -prin printer.txt \
     -str 6
cat printer.txt

Example run output:

./printer.sh
+ rm -vf printer.txt
'printer.txt' wurde entfernt
+ cat
+ sdasz80 -o putchar.s
+ cat
+ sdcc -mz80 --code-loc 0x1200 --no-std-crt0 putchar.rel c.c
+ makebin -p c.ihx
+ tail -c +4609
+ iDSK c.dsk -n -i c.bin -e 1200 -c 1200
DSK : c.dsk
Amsdos file : c.bin
Automatically generating header for file
C       .BIN 0
------------------------------------
+ mame cpc664 -flop1 c.dsk -skip_gameinfo -ab '\n\nrun "c\n' -prin printer.txt -str 6
Average speed: 99.98% (5 seconds)
+ cat printer.txt
Hello world from C

Another way to get data out of the emulator is to save to disk using caprice as the emulator. Caprice allows to save a ".dsk" image (mame doesn't). You can then use iDSK to extract the data (though I had to use the hexdump method and had to strip off some extra data - looks like a bug to me?).

About the video memory

As you can see above, to calculate the address of a pixel we used:

  char* a=0xc000+(y/8*80)+(2048*(y%8))+x/2;

This is valid for mode 0 graphics. For details about the different video modes see the wonderful CPCWiki. For mode 1 and 2 not much changes, only the x coordinate is divided by 4 and 8 respectively. But this is only part of the story. If you did scroll the calculation changes.

Hardware scrolling

In the following I assume mode 2. For hardware scrolling we can use the firmware function SCR SET OFFSET (0xBC05). S.a. the Firmware Guide. But if we do use hardware scrolling calculating the address of a pixel becomes a little bit more complicated (yes we also can use the firmware function SCR DOT POSITION (0xBC1D)), but to understand the video memory layout, the following C function helps:

/*
   scroff : screen offset [0,2046]
   x      : x coordinate  [0,639]
   y      : y coordinate  [0,199]
   returns pointer to screen byte
   credits go to lightforce6128
*/
inline
char* scr_dot_position(uint16_t screen_offset, uint16_t x, uint8_t y) {
       uint16_t x_offset    = x / 8; /* mode 2: 8, mode 1: 4, mode 0: 2 */
       uint16_t y_offset    = (uint16_t)(y / 8) * 80;
       uint16_t y_scanline  = (uint16_t)(y % 8) * 2048;
       return (char*)0xC000
       	      + ((screen_offset + x_offset + y_offset) % 2048)
	      + y_scanline;
}

Putting it all together, a scroll example:

#!/bin/bash -xe
if [ "x$1" = "x" ]; then
    FIXIMAGE=0
    REVVIDEO=true
    { cat <<EOF
H4sIAI361GgAA7VbTQ7dKAxOoswoqmYRjXoAdzfLHsGVZtFljz
BHsbrqMXrUaQgBG9vg5L1+Cx4B89mY3xDeNP1GrCpl2w0B3KYJ
UoxKDubfOf8CJ2EEPP3ErlIY8WKRuGjsB27gxbsxzpNWm1S0Jd
tylTBgADPkLDUPBBUubzRGMeXzlS9ra7mR+m4zPS9gleZq6bJz
MQRvYz2bK9LSBqDE9kU3Kt5g2skrLJtTivneXJRsH8BiwzbCIw
i4TPdEko9iaJpqo535LKwnEwc/3Zw/RkXpisy5C9ZR13MJsZqA
yDmNPiuAjQ6OcX+3ig3r4xEsbk4Ic66SbtWHY22IFZ8y88Wiya
IS23VSBrBumqX2+ZV6Lix8CQunCQ8OG51ZYVzTQWdSCSHSJ8D3
81S/8skq1Xg78qgIV8kzhcijX5sCUFaqDtRcOQ+dOJY4MFJ8E3
D+mP27rO7wXp23YHX1R6MHUiUT3XI4mq6M6nU8k5lKmgRwrOaX
bZTEyj6N495A4nXXLRSdk9ZR+6HpZchpi8rDPp1wrgtSUuDKsq
VdJYs4/aqIdPFcM3fHZU6bmHOslehvi+abIwfOGgQ25iao1EQP
EMz8YS4Wn832/NIpLRSBqVZ6nYmQPb57m087b4lNlskQLBYgS6
2AKQxX58ncc9tN7JH5xPcbHAEdwfridkRC2HR1ZXzbau+hjm0y
8z8dQc9fmI4H4A2mFAN+UXb2qgeGkzj2s493VbNSYCh8rZmhxA
jkKYruY9hoz9LKonaqAyUQzz1RnWHWViRG+Pp0FeSZMRnzeXZY
XpeoJ5qAfd2ctyvKGurhGtOfcWRHePzWUPqWP3ktOehXY80kWz
Pr4qDUdufl5FACZv+4ffpXQNNpwWZ5cVfM6ijw2rsVsmnHgU16
Jkqi6OW6uJrEGzD/6hIUpHRIsUZhwPREsg/SSTgqcwg8HYAJZn
OoV16G2FjEFJJN6VXrh3wMbN7IEDE5uI9Kb1QKqtTGk8DV30kG
nVSAw+JzY09fI7FmohJEkYXDa7pn1S2lB2ahFtpsbCmXEnBxsw
f3Z5m1eu+77tD9MzHgz9I+WRKDc13Vv/MEaOVQ/GT5vT31ji6V
M1MoQSy+Pz0m2vDmmgXnz7veH3446cB09ffTLb4w0x7tR/AIni
/kDIvhJhgViqwS49NIDlGXLWhGhamK9GPfZecQw8uGyzGmHVbn
SoJl2/DgdL7x6zLp7mEaY2Bxehaz6q3v1y4CWpA/AEu868KvN+
VN2APS7vIL5csHvnSqAxm0b3O/PxrpCIYTjF0e7hlxiXv99eHG
simG/IH3jsaZJB/157I0EcBA2xAfC5VkM66s3GSWhZNdOBJbj5
XSxNMPhYFynwb5wB92xvoPTwqOBWEPGQJ7EaozfcNt1Umr3/MV
hqtH8PZjihnZR/cbw6Z0LvjCp9tY0Y5HibGQr+TPHHW77iaDAP
g7EV+KZ1OmIpkC00oymbqTVGwwY0DG2QA6LracEduq0Zio1YWG
/JY1KqWnMNhUL+8mvdZ4oavvsn0yv+H3DylMssxrwMTNM6vDtP
9s1TBZG8DFyE2G9jobWmoVHP+Lym5GWjagQ3EPkV5npC062zQH
IpM9+eWvDL6UWIUrsMT2YoL6SHV3fQY72T9l3EdTTcldzwqata
e3XGm08GLfAStReUFeanDBM68id7dmpkEj9Whl7Z2du8jS8y0e
dvQt4Xhw+rQzvV4T6jMgCptk2CPVfOcP0FeELumqIr7c/rlPIb
CDmRzGvMW/ufiC1WW7ZWftRaAzoRFZeBljVHRnMnmJ6JtgHBZ+
AehnUf7lg4rSc6dQy8HqBUNh/YDDUny7jDGj2gMncX/3gOgJCx
fr39q24m9Dl5RS+OEmJfEH7AxxctLFd8PbGiMZUGIYXwjpU3OE
D47gfSQma8vauf/F/IolNmeiZXLWBzPxb2aFi1OJN2N8rSapBt
e8vFqJ0ejn0DNqyyZJXW3lQtPbnnWCV4LCVK8AdNKDPdrhu3e8
G4QOaBod5V9DkMLoDo5MMlcuupkZnTEM1Ow3D2xhkDWezKhNwB
TGrUiS46rOhz0QZrXAbnQEsU7KBe0l2UFpEzOKJ59B3R9eqz21
GDTsAdPUi2W4vX7bq12AemdVhTZz7XGg8fW3PNTD4ct1wjlVU6
zlydCu9sdVWezKdy2FRuJPU/T1piq9gjlO3LH+Nm0kShguWhsu
g57jLcdDbfegRp+pBB2u1o/E0jaddW8GtiwRPoU7bAyyyZo6VF
Jp7BrTV9hAkin2GLgTn31vPL9UmL7Mv8IBvhJxIYXFxT0p0KrQ
vFoBIm4e7ibMp4XGgD0vY/01Dd7noJd5Id8Bcip/2/GpxqSS7X
MPBrCWe3bRqXEttKKPJ4j/AXt2uC0AQAAA
EOF
}|base64 -d|zcat > screen.bin
else
    FIXIMAGE=1
    REVVIDEO=false
    convert "$1" -resize "640x200!" pgm:- \
	|pamditherbw|convert pam:- pbm:-|{
	x=0
	# skip header
	while read; do
	    if echo $REPLY|grep -q "^ *#"; then
		echo skip comment >&2
	    else
		x=$((x+1))
		if [ $x -ge 2 ]; then
		    break;
		fi
	    fi
	done
	cat
    } > screen.bin
fi
iDSK c.dsk -n -i screen.bin -t 1

# todo: many emulators hang on printer output!
{ cat <<EOF
print #8,"hello world from basic to the printer port"
mode 2
memory &4000-1
$(if ${REVVIDEO}; then
     echo "border 0:ink 0,0:ink 1,26";
  else
     echo "border 26:ink 0,26:ink 1,0"; fi)
load "c.bin",&8000
load "screen.bin",&c000
call &8000
while(1)
 call &bd19 ' sync to blank
 if inkey(67)=0 or (joy(0) and 1) then |scrollup
 if inkey(69)=0 or (joy(0) and 2) then |scrolldown
 if inkey(34)=0 or (joy(0) and 4) then |scrollleft
 if inkey(27)=0 or (joy(0) and 8) then |scrollright
wend
EOF
}|nl -w1|unix2dos>c.bas
iDSK c.dsk -i c.bas -t 0
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

.module crt0
	.globl	_main
	.globl  _rsx_workspace
	.globl  _rsx_jump_table

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

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

init:
	;; Initialise global variables
	call    gsinit
	;; rsx init
	ld hl,#_rsx_workspace
	ld bc,#_rsx_jump_table
	call #0xbcd1
	call	_main
	jp	_exit

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

	.area	_DATA
  .area   _BSS
  .area   _HEAP

  .area   _CODE
__clock::
	ret

_exit::
	ret

	.area   _GSINIT
gsinit::

.area   _GSFINAL
    	ret

EOF
sdasz80 -o crt0_cpc.s
cat > util.s <<'EOF'
.area _CODE
.globl  _scroll_down
.globl  _scroll_up
.globl  _scroll_left
.globl  _scroll_right

_putchar::
	ld a,l
1$:
	; output to printer
	; (todo: many emulators hang on printer output!)
	call 0xbd2b
	jp nc,1$
	ret

_get_time::
	call #0xbd0d ;kl time please
	ex de,hl
	ret

_rsx_jump_table::
	.word name_table  ;address pointing to RSX commands
	jp _scroll_down
	jp _scroll_up
	jp _scroll_left
	jp _scroll_right

name_table:
	.str "SCROLLDOW"
	.byte "N"+0x80
	.str "SCROLLU"
	.byte "P"+0x80
	.str "SCROLLLEF"
	.byte "T"+0x80
	.str "SCROLLRIGH"
	.byte "T"+0x80
	.byte 0           ;end of name table marker

_rsx_workspace::          ;Space for kernel to use
.byte 0,0,0,0
EOF
sdasz80 -o util.s

cat > c.c <<EOF
#include <stdint.h>
#include <stdio.h>
#include <string.h>
#include <stdlib.h>

inline void sync_to_blank(void)
{
__asm
	call #0xbd19 ; sync to blank
__endasm;
}
inline void wait_for_keypress(void)
{
__asm
	call #0xbb18
__endasm;
}
void scroll_down(void);
void scroll_up(void);
void scroll_left(void);
void scroll_right(void);
uint16_t get_time(void);

#if $FIXIMAGE
void fix_image(void);
#endif

/*
   scroff : screen offset [0,2046]
   x      : x coordinate  [0,639]
   y      : y coordinate  [0,199]
   returns pointer to screen byte
   credits go to lightforce6128
*/
inline
char* scr_dot_position(uint16_t screen_offset, uint16_t x, uint8_t y) {
       uint16_t x_offset    = x / 8; /* mode 2: 8, mode 1: 4, mode 0: 2 */
       uint16_t y_offset    = (uint16_t)(y / 8) * 80;
       uint16_t y_scanline  = (uint16_t)(y % 8) * 2048;
       return (char*)0xC000
       	      + ((screen_offset + x_offset + y_offset) % 2048)
	      + y_scanline;
}

#define SCR_NEXT_LINE(p) do{p+=0x800;if (!((uint16_t)p&0x3800)) { \
	p-=0x4000;char a=((uint16_t)p)>>11;p+=0x50;char b=((uint16_t)p)>>11; \
	if (a!=b) p-=0x800;};}while(0)

/* todo: macro version? */
inline char* scr_prev_line(char* p) {
      uint16_t x=(uint16_t)p;
      x-=0x800;
      if (((x>>8)&0x38)==0x38) {
      	 x+=0x4000;
	 char a=x>>11;
	 x-=0x50;
	 char b=x>>11;
	 if (a!=b) x+=0x800;
      }
      return (char*)x;
}

#define SCR_NEXT_BYTE(x) do{ \
	++x;if (!((uint16_t)x&0x7ff)) ((char*)(&x))[1]-=0x8;}while(0)

/* todo: test pass by reference? */
inline char* scr_prev_byte(char* x) {
       if (!((uint16_t)x&0x07ff)) x+=0x800;
       return --x;
}
#define SCR_PREV_BYTE(x) do{ \
	if (!((uint16_t)x&0x07ff)) ((char*)(&x))[1]+=0x8; --x;}while(0)

void main(void)
{
  uint16_t f,dt,s;

  printf("hello world from C to the printer port\r\n");

#if $FIXIMAGE
  fix_image();
#endif

  s = get_time();
  for (f=0;f<50;++f) {
	sync_to_blank();
	scroll_down();
  }
  dt=(get_time()-s);
  printf("%2dframes/s\r\n",f*300/dt);

  s = get_time();
  for (f=0;f<50;++f) {
	sync_to_blank();
	scroll_up();
  }
  dt=(get_time()-s);
  printf("%2dframes/s\r\n",f*300/dt);

  s = get_time();
  for (f=0;f<40;++f) {
	sync_to_blank();
	scroll_right();
  }
  dt=(get_time()-s);
  printf("%2dframes/s\r\n",f*300/dt);

  s = get_time();
  for (f=0;f<40;++f) {
	sync_to_blank();
	scroll_left();
  }
  dt=(get_time()-s);
  printf("%2dframes/s\r\n",f*300/dt);
}

inline char* scr_line_position(uint16_t scroff, char y)
{
	uint16_t y_offset    = (uint16_t)(y / 8) * 80;
	uint16_t y_scanline  = (uint16_t)(y % 8) * 2048;
	return (char*)0xC000 + ((scroff + y_offset) % 2048) + y_scanline;
}

void set_offset(uint16_t newoffset) {
	__asm
	call #0xbc05
	__endasm;
}

/*
  The video memory wraps on every 2048(0x800) bytes
  boundary.  The idea is to calculate how many bytes we can
  copy without crossing a boundary.

  The from or the to pointer might cross the boundary first
  or we might not cross any boundary at all.

  A row is 80 Bytes (<2048) => we can cross a boundary only
  once.

  note: the memory areas might overlap
  todo: memcpy doesn't allow overlap => use memmove?
  (unfortunately the memmove doesn't inline
  for now stay with memcpy which maps to ldir
  note/todo:
  looks like ldir isn't the fastest method to copy bytes)
*/
void copy_row(char* f, char* t)
{
	uint16_t fc;
	uint16_t tc;
	char count;
	char c;
	fc=(uint16_t)0x800-((uint16_t)f&0x7ff);
	tc=(uint16_t)0x800-((uint16_t)t&0x7ff);
	count=80;
	if (fc<tc) {
	   if (count<fc) {
	      memcpy(t,f,count);
	   }else{
		c=fc;
	      	memcpy(t,f,c);
	      	f=f-0x800+c;
	      	t=t+c;
	      	tc=tc-c;
	      	count=count-c;
	      	if (count<tc) {
		   memcpy(t,f,count);
		}else{
			c=tc;
			memcpy(t,f,c);
			f=f+c;
			t=t-0x800+c;
			count=count-c;
			memcpy(t,f,count);
		}
	   }
	}else{
	   if (count<tc) {
	      memcpy(t,f,count);
	   }else{
		c=tc;
	      	memcpy(t,f,c);
	      	f=f+c;
	      	t=t-0x800+c;
	      	fc=fc-c;
	      	count=count-c;
	      	if (count<fc) {
		   memcpy(t,f,count);
		}else{
			c=fc;
			memcpy(t,f,c);
			f=f-0x800+c;
			t=t+c;
			count=count-c;
			memcpy(t,f,count);
		}
	   }
	}
}

void scroll_down(void)
{
	/* firmware keeps offset there */
	uint16_t oldoffset=*((uint16_t *)0xb7c4);
	uint16_t newoffset=(oldoffset+80)%2048;
	set_offset(newoffset);
	char *f;
	char *t;
	for (char y=0;y<8;++y) {
	    f=scr_line_position(oldoffset, y);
	    t=scr_line_position(newoffset, 200-8+y);
	    copy_row(f,t);
	}
}

void copy_row_reverse(char* f, char* t)
{
	uint16_t fc;
	uint16_t tc;
	char count;
	char c;
	fc=((uint16_t)f&0x7ff)+1;
	tc=((uint16_t)t&0x7ff)+1;
	count=80;
	if (fc<tc) {
	   if (count<fc) {
	      memmove(t-count+1,f-count+1,count);
	   }else{
		c=fc;
	      	memmove(t-c+1,f-c+1,c);
	      	f=f+0x800-c;
	      	t=t-c;
	      	tc=tc-c;
	      	count=count-c;
	      	if (count<tc) {
		   memmove(t-count+1,f-count+1,count);
		}else{
			c=tc;
			memmove(t-c+1,f-c+1,c);
			f=f-c;
			t=t+0x800-c;
			count=count-c;
			memmove(t-count+1,f-count+1,count);
		}
	   }
	}else{
	   if (count<tc) {
	      memmove(t-count+1,f-count+1,count);
	   }else{
		c=tc;
	      	memmove(t-c+1,f-c+1,c);
	      	f=f-c;
	      	t=t+0x800-c;
	      	fc=fc-c;
	      	count=count-c;
	      	if (count<fc) {
		   memmove(t-count+1,f-count+1,count);
		}else{
			c=fc;
			memmove(t-c+1,f-c+1,c);
			f=f+0x800-c;
			t=t-c;
			count=count-c;
			memmove(t-count+1,f-count+1,count);
		}
	   }
	}
}

void scroll_up(void)
{
	uint16_t oldoffset=*((uint16_t *)0xb7c4);
	uint16_t newoffset=(oldoffset-80)%2048;
	set_offset(newoffset);
	char *f;
	char *t;
	for (char y=0;y<8;++y) {
	    f=scr_dot_position(oldoffset, 639, (int)200-8+y);
	    t=scr_dot_position(newoffset, 639, y);
	    /* note:
	       we copy from right to left because of overlap */
	    copy_row_reverse(f,t);
	}
}

/* todo: slow */
void scroll_left(void)
{
	uint16_t oldoffset=*((uint16_t *)0xb7c4);
	uint16_t newoffset=(oldoffset-2)%2048;
	set_offset(newoffset);
	char *fl;
	char *tl;
	char *f;
	char *t;
	char y=0;
	fl=scr_dot_position(oldoffset, 640-16, y);
	tl=scr_dot_position(newoffset, 0, y);
	while(1) {
	    *tl=*fl;
	    t=tl;
	    f=fl;
	    SCR_NEXT_BYTE(f);
	    SCR_NEXT_BYTE(t);
	    *t=*f;
	    ++y;
	    if (y==200) break;
	    SCR_NEXT_LINE(fl);
	    SCR_NEXT_LINE(tl);
	}
}

/* todo: slow */
void scroll_right(void)
{
	uint16_t oldoffset=*((uint16_t *)0xb7c4);
	uint16_t newoffset=(oldoffset+2)%2048;
	set_offset(newoffset);
	char *fl;
	char *tl;
	char *f;
	char *t;
	/* note: copy in reverse because of overlap */
	char y=199;
	fl=scr_dot_position(oldoffset, 8, y);
	tl=scr_dot_position(newoffset, 640-8, y);
	while(1) {
	    *tl=*fl;
	    t=tl;
	    f=fl;
	    SCR_PREV_BYTE(f);
	    SCR_PREV_BYTE(t);
	    *t=*f;
	    --y;
	    if (y==255) break;
	    fl=scr_prev_line(fl);
	    tl=scr_prev_line(tl);
	}
}

#if $FIXIMAGE
void fix_image(void) {
     for (char y=0;y<200;++y) {
     	 char* src=(char*)0xc000+(uint16_t)y*80;
     	 char* dest=scr_line_position(0,y)-0x8000;
	 memcpy(dest,src,80);
     }
     // memset((char*)0xc000,0,0x4000);
     memcpy((char*)0xc000,(char*)0x4000,0x4000);
}
#endif
EOF
sdcc -mz80 \
     --code-loc 0x$(bc <<<"obase=16;ibase=16;8000+38") \
     --data-loc 0 \
     --no-std-crt0 crt0_cpc.rel util.rel c.c
makebin -yo A -p c.ihx|tail -c +$((0x8000+1))>c.bin
iDSK c.dsk -i c.bin -e 8000 -c 8000

rm -vf printer.txt
mame cpc664 -flop1 c.dsk -skip_gameinfo -ab '\n\nrun "c\n' \
     -prin printer.txt \
     -snapsize 768x544 -aviwrite /tmp/p.avi -str 25
AV_LOG_FORCE_NOCOLOR=1 ffmpeg -ss 0.5 -y \
		       -i /tmp/p.avi \
		       -r 25 -pix_fmt yuv420p \
		       -q:a 0.1 /tmp/p.mp4
cat printer.txt

download.

Start emulator. (go fullscreen) Note: after the initial scrolling you can use the cursor keys to scroll (or q,a,o,p) (after you have clicked the emulator to give it focus). As the main loop then is a basic program you can also break it with escape. Use "list" to list the code and "cont" to continue scrolling. S.a. How to embed an Amstrad CPC emulator. and emulators as embedded file viewers.

Bringing LISP to the CPC

First try: tinylisp

C definitely is easier to write than assembly, but I start missing gauche scheme. Let's bring tinylisp to the CPC. (Please don't blame the original authors for the bugs I introduced. Note: you have to click the emulator to give focus and it looks like input doesn't work on mobile.)

#!/bin/bash -xe
#| -*- mode: Shell-script; indent-tabs-mode: nil; fill-column: 80 -*-
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>tinylisp.bas
iDSK c.dsk -i tinylisp.bas -t 0
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?)
        ld sp,#0x8000-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
/* tinylisp-float-opt.c with single float precision NaN boxing
   (optimized version) by Robert A. van Engelen 2022 */

/*
BSD 3-Clause License

Copyright (c) 2021, Robert van Engelen
Copyright (c) 2025, Jens Thiele
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.
*/

#include <stdint.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>

void myexit(void)
{
  /* printf("myexit: todo\r\n"); */
  while(1)
        ;
}

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

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;
}

const char* input_s;
int input_pos=0;
int mygetchar()
{
   if (input_pos<strlen(input_s)) {
      int r=input_s[input_pos];
      input_pos++;
      return r;
   }
   return getchar();
}

#define I uint16_t
#define L float
#define T(x) *(uint32_t*)&x>>20
#define A (char*)cell
#define N 2048 /* N should not exceed 262144 = 2^20/4 cells = 1048576 bytes */
I hp=0,sp=N,ATOM=0x7fc,PRIM=0x7fd,CONS=0x7fe,CLOS=0x7ff,NIL=0xfff;
L cell[N],nil,tru,err,env;
L box(I t,I i) { L x; *(uint32_t*)&x = (uint32_t)t<<20|i; return x; }
I ord(L x) { return *(uint32_t*)&x & 0xfffff; }
L num(L n) { return n; }
I equ(L x,L y) { return *(uint32_t*)&x == *(uint32_t*)&y; }
L atom(const char *s) {
 I i = 0; while (i < hp && strcmp(A+i,s)) i += strlen(A+i)+1;
 if (i == hp && (hp += strlen(strcpy(A+i,s))+1) > sp<<2) abort();
 return box(ATOM,i);
}
L cons(L x,L y) {
  cell[--sp] = x; cell[--sp] = y;
  if (hp > sp<<2) abort(); return box(CONS,sp);
}
L car(L p) { return (T(p)&~(CONS^CLOS)) == CONS ? cell[ord(p)+1] : err; }
L cdr(L p) { return (T(p)&~(CONS^CLOS)) == CONS ? cell[ord(p)] : err; }
L pair(L v,L x,L e) { return cons(cons(v,x),e); }
L closure(L v,L x,L e) { return box(CLOS,ord(pair(v,x,equ(e,env) ? nil : e))); }
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)) : err;
}
I not(L x) { return T(x) == NIL; }
I let(L x) { return !not(x) && !not(cdr(x)); }
L eval(L,L),parse();
L evlis(L t,L e) {
 L s,*p;
 for (s = nil,p = &s; T(t) == CONS; p = cell+sp,t = cdr(t))
     *p = cons(eval(car(t),e),nil);
 if (T(t) == ATOM) *p = assoc(t,e);
 return s;
}
L evarg(L *t,L *e,I *a) {
 L x;
 if (T(*t) == ATOM) *t = assoc(*t,*e),*a = 1;
 x = car(*t); *t = cdr(*t);
 return *a ? x : eval(x,*e);
}
uint16_t globali;
L call(L f) {
  globali=f;
  __asm
        ld hl,(_globali)
        call _JP_HL
  __endasm;
  return (L)0;
}
L poke(L x,L y) {
  uint16_t a=x;
  char v=y;
  *((char*)a)=v;
  return y;
}
L peek(L x) {
  uint16_t a=x;
  return *((char*)a);
}
L lputchar(L x) {
  putchar((char) x);
  return x;
}

L f_eval(L t,L *e) { I a = 0; return evarg(&t,e,&a); }
L f_quote(L t,L *_) { return car(t); }
L f_cons(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return cons(x,evarg(&t,e,&a));
}
L f_car(L t,L *e) { I a = 0; return car(evarg(&t,e,&a)); }
L f_cdr(L t,L *e) { I a = 0; return cdr(evarg(&t,e,&a)); }
L f_add(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n += evarg(&t,e,&a);
  return num(n);
}
L f_sub(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n -= evarg(&t,e,&a);
  return num(n);
}
L f_mul(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n *= evarg(&t,e,&a);
  return num(n);
}
L f_div(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); while (!not(t)) n /= evarg(&t,e,&a);
  return num(n);
}
L f_int(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); return n<1e16 && n>-1e16 ? (int)n : n;
}
L f_lt(L t,L *e) {
  I a = 0; L n = evarg(&t,e,&a); return n - evarg(&t,e,&a) < 0 ? tru : nil;
}
L f_eq(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return equ(x,evarg(&t,e,&a)) ? tru : nil;
}
L f_pair(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return T(x) == CONS ? tru : nil;
}
L f_not(L t,L *e) {
  I a = 0; return not(evarg(&t,e,&a)) ? tru : nil;
}
L f_or(L t,L *e) {
  I a = 0; L x = nil; while (!not(t) && not(x)) x = evarg(&t,e,&a); return x;
}
L f_and(L t,L *e) {
  I a = 0; L x = tru; while (!not(t) && !not(x)) x = evarg(&t,e,&a); return x;
}
L f_cond(L t,L *e) {
  while (not(eval(car(car(t)),*e))) t = cdr(t); return car(cdr(car(t)));
}
L f_if(L t,L *e) {
  return car(cdr(not(eval(car(t),*e)) ? cdr(t) : t));
}
L f_leta(L t,L *e) {
  for (;let(t); t = cdr(t)) *e = pair(car(car(t)),eval(car(cdr(car(t))),*e),*e);
  return car(t);
}
L f_lambda(L t,L *e) { return closure(car(t),car(cdr(t)),*e); }
L f_define(L t,L *e) {
  env = pair(car(t),eval(car(cdr(t)),*e),env); return car(t);
}
L f_call(L t,L *e) { I a = 0; return call(evarg(&t,e,&a)); }
L f_poke(L t,L *e) {
  I a = 0; L x = evarg(&t,e,&a); return poke(x,evarg(&t,e,&a));
}
L f_peek(L t,L *e) { I a = 0; return peek(evarg(&t,e,&a)); }
L f_begin(L t, L *e) {
  for (; let(t); t=cdr(t)) eval(car(t),*e);
  return car(t);
}
L f_putchar(L t, L *e) { I a = 0; return lputchar(evarg(&t,e,&a)); }
void load_file(char* fname, char* addr);
L f_load(L t, L *e) {
  I a = 0;
  L fnl=evarg(&t,e,&a);
  L r=evarg(&t,e,&a);
  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_getchar(L t, L *e) { int c=getchar(); return (L)c; }
/* todo: really echo_read _and_ quiet? */
char echo_read=1;
L f_echo(L t, L *e) {
  I a = 0; L x = evarg(&t,e,&a); echo_read=(uint16_t)x; return x;
}
char quiet=0;
L f_quiet(L t, L *e) {
  I a = 0; L x = evarg(&t,e,&a); quiet=(uint16_t)x; return x;
}

struct { const char *s; L (*f)(L,L*); short t; } prim[]={
{"eval",  f_eval,  1},{"quote", f_quote, 0},{"cons", f_cons,0},
{"car", f_car, 0},{"cdr",f_cdr,0},{"+",   f_add, 0},
{"-",     f_sub,   0},{"*",     f_mul,   0},{"/",    f_div, 0},
{"int", f_int, 0},{"<",  f_lt, 0},{"eq?", f_eq,  0},
{"or",    f_or,    0},{"and",   f_and,   0},{"not",  f_not, 0},
{"cond",f_cond,1},{"if", f_if, 1},{"let*",f_leta,1},
{"lambda",f_lambda,0},{"define",f_define,0},{"pair?",f_pair,0},
{"call",f_call,0},{"poke",f_poke,0},{"peek",f_peek,0},
{"begin",f_begin,1},{"putchar",f_putchar,0},{"load",f_load,0},
{"getchar",f_getchar,0},{"set-echo!",f_echo,0},{"set-quiet!",f_quiet,0},
{0}};

void assign(L v,L x,L e) {
     while (!equ(v,car(car(e)))) e = cdr(e); cell[ord(car(e))] = x;
}
L eval(L x,L e) {
 I a; L f,v,d,g = nil,h;
 while (1) {
  if (T(x) == ATOM) return assoc(x,e);
  if (T(x) != CONS) return x;
  f = eval(car(x),e); x = cdr(x);
  if (T(f) == PRIM) {
   x = prim[ord(f)].f(x,&e);
   if (prim[ord(f)].t) continue;
   return x;
  }
  if (T(f) != CLOS) return err;
  v = car(car(f));
  if (equ(f,g)) d = e;
  else if (not(d = cdr(f))) d = env;
  for (a = 0; T(v) == CONS; v = cdr(v)) d = pair(car(v),evarg(&x,&e,&a),d);
  if (T(v) == ATOM) d = pair(v,a ? x : evlis(x,e),d);
  if (equ(f,g)) {
   for (; !equ(d,e) && sp == ord(d); d = cdr(d),sp += 4)
       assign(car(car(d)),cdr(car(d)),e);
   for (; !equ(d,h) && sp == ord(d); d = cdr(d)) sp += 4;
  }
  x = cdr(car(f)); e = d; g = f; h = e;
 }
}
char buf[40],see = ' ';
void look() {
     int c = mygetchar();
     if (echo_read) {
        putchar(c);
        if (c=='\r') putchar('\n');
     }
     see = c;
     if (c == EOF) myexit();
}
I seeing(char c) { return c == ' ' ? see > 0 && see <= c : see == c; }
char get() { char c = see; look(); return c; }
char scan() {
 int i = 0;
 while (seeing(' ')) look();
 if (seeing('(') || seeing(')') || seeing('\'')) buf[i++] = get();
 else do buf[i++] = get();
 while (i < 39 && !seeing('(') && !seeing(')') && !seeing(' '));
 return buf[i] = 0,*buf;
}
L Read() { return scan(),parse(); }
L list() {
 L t,*p;
 for (t = nil,p = &t; ; *p = cons(parse(),nil),p = cell+sp) {
  if (scan() == ')') return t;
  if (*buf == '.' && !buf[1]) return *p = Read(),scan(),t;
 }
}
L parse() {
 L n; int i;
 if (*buf == '(') return list();
 if (*buf == '\'') return cons(atom("quote"),cons(Read(),nil));
 return mysscanf(buf,"%g%n",&n,&i) > 0 && !buf[i] ? n : atom(buf);
}
void print(L);
void printlist(L t) {
 for (putchar('('); ; putchar(' ')) {
  print(car(t));
  if (not(t = cdr(t))) break;
  if (T(t) != CONS) { printf(" . "); print(t); break; }
 }
 putchar(')');
}
void print(L x) {
 if (quiet) return;
 if (T(x) == NIL) printf("()");
 else if (T(x) == ATOM) printf("%s",A+ord(x));
 else if (T(x) == PRIM) printf("<%s>",prim[ord(x)].s);
 else if (T(x) == CONS) printlist(x);
 else if (T(x) == CLOS) printf("{%u}",ord(x));
 else if (x>=0) printf("%lu",(uint32_t)x);
 else printf("-%lu",(uint32_t)(-x));
}
void gc() { sp = ord(env); }

void main() {
 I i;
 printf("tinylisp 0.0.13");
 input_s="\
(define null? not)\r\
(define err? (lambda (x) (eq? x 'ERR)))\r\
(define number? (lambda (x) (eq? (* 0 x) 0)))\r\
(define symbol? (lambda (x)\r\
(and x (not (err? x)) (not (number? x)) (not (pair? x)))))\r\
(define list? (lambda (x) (if (pair? x) (list? (cdr x)) (not x))))\r\
(define equal? (lambda (x y)\r\
 (or (eq? x y) (and (pair? x) (pair? y)\r\
  (equal? (car x) (car y))\r\
  (equal? (cdr x) (cdr y))))))\r\
(define negate (lambda (n) (- 0 n)))\r\
(define > (lambda (x y) (< y x)))\r\
(define <= (lambda (x y) (not (< y x))))\r\
(define >= (lambda (x y) (not (< x y))))\r\
(define = (lambda (x y) (eq? (- x y) 0)))\r\
(define list (lambda args args))\r\
(define cadr (lambda (x) (car (cdr x))))\r\
(define caddr (lambda (x) (car (cdr (cdr x)))))\r\
(define length-tr (lambda (t n) (if t (length-tr (cdr t) (+ n 1)) n)))\r\
(define length (lambda (t) (length-tr t 0)))\r\
(define append1 (lambda (s t) (if s (cons (car s) (append1 (cdr s) t)) t)))\r\
(define append (lambda (t . args) (if args (append1 t (append . args)) t)))\r\
(define reverse-tr (lambda (r t)\r\
 (if t (reverse-tr (cons (car t) r) (cdr t)) r)))\r\
(define reverse (lambda (t) (reverse-tr () t)))\r\
(define any? (lambda (f t)\r\
 (if t (if (f (car t)) #t (any? f (cdr t))) ())))\r\
(define mapcar (lambda(f t) (if t (cons (f (car t)) (mapcar f (cdr t))) ())))\r\
(define map (lambda (f . args)\r\
 (if (any? null? args)\r\
  ()\r\
  (let*\r\
   (x (mapcar car args))\r\
   (t (mapcar cdr args))\r\
   (cons (f . x) (map f . t))))))\r\
(define iota2 (lambda(i r)\r\
 (if (< 0 i)\r\
  (iota2 (- i 1) (cons i r))\r\
  (cons i r))))\r\
(define iota (lambda(c) (iota2 (- c 1) ())))\r\
(define cls (lambda() (begin (call 47980) (call 48148))))\r\
(define display-image (lambda(x)\r\
 (if (< x $i) (begin (load (list (+ x 48)) 49152) (display-image (+ x 1)))\r\
  x)))\r\
(set-echo! 0)\r\
(set-quiet! 1)\r\
(cls)\r\
(display-image 0)\r\
(getchar)\r\
(cls)\r\
(set-echo! 1)\r\
(set-quiet! 0)\r\
"
#if 0
"(map cons (iota 5) (iota 5))\r\
(define fact (lambda(n) (if (< n 2) 1 (* n (fact (- n 1))))))\r(fact 7)\r\
(define sum2 (lambda(n a) (if (< n 1) a (sum2 (- n 1) (+ a n)))))\r\
(define sum (lambda(n) (sum2 n 0)))\r\
(sum 100)\r(/ (* 101 100) 2)\r\
(poke 49152 255)\r\
(peek 49152)\r\
(define fill (lambda(a c v)\r\
 (if (< c 1) 0 (begin (poke a v) (fill (+ a 1) (- c 1) v)))))\r\
(fill 49152 80)\r\
(begin (putchar 72)(putchar 101)(putchar 108)\r\
 (putchar 108)(putchar 111)(putchar 13)(putchar 10))\r"
#endif
;

 nil = box(NIL,0); err = atom("ERR"); tru = atom("#t"); env = pair(tru,tru,nil);
 for (i = 0; prim[i].s; ++i) env = pair(atom(prim[i].s),box(PRIM,i),env);
 while (1) {
       if (!quiet) printf("\r\n%u>",sp-hp/4);
       print(eval(Read(),env));
       gc();
 }
}
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 "tinylisp\n' \
     -prin printer.txt
dos2unix < printer.txt|cat -v

download.

go fullscreen Start emulator.

That's already quite some fun. But tinylisp has it's limitations especially regarding tail recursion. Let's do better using Lisp in 1k lines of C.

Second try: lisp1k

Porting Lisp in 1k lines of C wasn't that hard. At first the garbage collector didn't work, but after fixing one uninitialized use and some 16 vs. 32 bits int issues it worked :-) (todo: report upstream).

#!/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

download.

go fullscreen Start emulator.

A small adventure game written using this.

Comments?

Comments, suggestions? Feel free to mail me.