changeset 0:5dd13b8deb54

Basis
author Mike Spivey <mike@cs.ox.ac.uk>
date Thu, 16 Aug 2018 13:59:09 +0100
parents
children b683d796e07e
files .gitignore .hgignore README keiko/Makefile keiko/config.h keiko/config.mk keiko/dynlink.c keiko/exec.h keiko/gc0.c keiko/lib.c keiko/lib.k keiko/linker.c keiko/loader.c keiko/obcommon.h keiko/oblink.c keiko/oblink.h keiko/obx.h keiko/primtab.h keiko/support.c keiko/symtab.c keiko/trace.c keiko/util.c keiko/util.h keiko/xmain.c lab0/Makefile lab0/eval.ml lab0/eval.mli lab0/lexer.mli lab0/lexer.mll lab0/main.ml lab0/memory.ml lab0/memory.mli lab0/parser.mly lab0/tree.mli lab1/Makefile lab1/case.p lab1/compile lab1/gcd.p lab1/keiko.ml lab1/keiko.mli lab1/kgen.ml lab1/kgen.mli lab1/lexer.mli lab1/lexer.mll lab1/loop.p lab1/main.ml lab1/parser.mly lab1/peepopt.ml lab1/peepopt.mli lab1/repeat.p lab1/tree.ml lab1/tree.mli lab2/Makefile lab2/array.p lab2/binary.p lab2/check.ml lab2/check.mli lab2/compile lab2/dict.ml lab2/dict.mli lab2/gcd.p lab2/keiko.ml lab2/keiko.mli lab2/kgen.ml lab2/kgen.mli lab2/lexer.mli lab2/lexer.mll lab2/main.ml lab2/parser.mly lab2/pascal.p lab2/peepopt.ml lab2/peepopt.mli lab2/tree.ml lab2/tree.mli lab3/Makefile lab3/bug.p lab3/check.ml lab3/check.mli lab3/compile lab3/compose.p lab3/dict.ml lab3/dict.mli lab3/digits.p lab3/fac.p lab3/fac0.p lab3/gcd.p lab3/gcdfun.p lab3/keiko.ml lab3/keiko.mli lab3/kgen.ml lab3/kgen.mli lab3/lexer.mli lab3/lexer.mll lab3/main.ml lab3/parser.mly lab3/peepopt.ml lab3/peepopt.mli lab3/sumpow.p lab3/sumpow2.p lab3/tree.ml lab3/tree.mli lab4/Makefile lab4/check.ml lab4/check.mli lab4/compile lab4/dict.ml lab4/dict.mli lab4/fixup.s lab4/jumpopt.ml lab4/jumpopt.mli lab4/lexer.mli lab4/lexer.mll lab4/mach.ml lab4/mach.mli lab4/main.ml lab4/optree.ml lab4/optree.mli lab4/parser.mly lab4/pas0.c lab4/promote.sed lab4/regs.ml lab4/regs.mli lab4/share.ml lab4/share.mli lab4/simp.ml lab4/simp.mli lab4/target.ml lab4/target.mli lab4/test/allregs.p lab4/test/apply.p lab4/test/array.p lab4/test/baz.p lab4/test/biglocal.p lab4/test/binsearch.p lab4/test/bitnot.p lab4/test/callshare.p lab4/test/choices.p lab4/test/choices2.p lab4/test/choices3.p lab4/test/choose.p lab4/test/cpsfac.p lab4/test/cpsfib.p lab4/test/cse.p lab4/test/digits.p lab4/test/fac.p lab4/test/fib.p lab4/test/flip.p lab4/test/foo.p lab4/test/forloop.p lab4/test/funny.p lab4/test/gcd.p lab4/test/immed.p lab4/test/infwhile.p lab4/test/list.p lab4/test/locarray.p lab4/test/matsum.p lab4/test/memkill.p lab4/test/mob.p lab4/test/mult.p lab4/test/mutual.p lab4/test/nasty.p lab4/test/negate.p lab4/test/nest.p lab4/test/nop.p lab4/test/not.p lab4/test/pascal.p lab4/test/pprolog.p lab4/test/print.p lab4/test/print5.p lab4/test/prob3-3.p lab4/test/ptr.p lab4/test/queens.p lab4/test/queens2.p lab4/test/queens3.p lab4/test/record.p lab4/test/record0.p lab4/test/regkill.p lab4/test/rep1.p lab4/test/rep2.p lab4/test/rep3.p lab4/test/rep4.p lab4/test/repchar.p lab4/test/reverse.p lab4/test/search.p lab4/test/shift.p lab4/test/spill.p lab4/test/strcopy.p lab4/test/string.p lab4/test/sudoku.p lab4/test/sumpower.p lab4/test/swap.p lab4/test/twice.p lab4/test/varparam.p lab4/tgen.ml lab4/tgen.mli lab4/tran.ml lab4/tran.mli lab4/tree.ml lab4/tree.mli lab4/util.ml lib/Makefile lib/bytes.ml lib/growvect.ml lib/growvect.mli lib/print.ml lib/print.mli lib/source.ml lib/source.mli ppc/Makefile ppc/Manifest ppc/check.ml ppc/check.mli ppc/compile ppc/dict.ml ppc/dict.mli ppc/keiko.ml ppc/keiko.mli ppc/kgen.ml ppc/kgen.mli ppc/lexer.mli ppc/lexer.mll ppc/mach.ml ppc/mach.mli ppc/main.ml ppc/parser.mly ppc/peepopt.ml ppc/peepopt.mli ppc/promote.sed ppc/test/apply.p ppc/test/array.p ppc/test/baz.p ppc/test/biglocal.p ppc/test/bitnot.p ppc/test/callshare.p ppc/test/choose.p ppc/test/cpsfac.p ppc/test/cpsfib.p ppc/test/digits.p ppc/test/fac.p ppc/test/fib.p ppc/test/flip.p ppc/test/foo.p ppc/test/funny.p ppc/test/gcd.p ppc/test/infloop.p ppc/test/list.p ppc/test/memkill.p ppc/test/mult.p ppc/test/mutual.p ppc/test/nest.p ppc/test/nop.p ppc/test/pascal.p ppc/test/print.p ppc/test/print5.p ppc/test/prob3-3.p ppc/test/ptr.p ppc/test/queens.p ppc/test/queens2.p ppc/test/queens3.p ppc/test/record.p ppc/test/record0.p ppc/test/recrec.p ppc/test/regkill.p ppc/test/repchar.p ppc/test/search.p ppc/test/strcopy.p ppc/test/string.p ppc/test/sumarray.p ppc/test/sumpower.p ppc/test/twice.p ppc/test/varparam.p ppc/tree.ml ppc/tree.mli ppc/util.ml tools/Makefile tools/ecsx tools/known_hosts tools/nclex.mll tools/ncmain.ml tools/ncparse.mly tools/pibake.in tools/sshconfig.in
diffstat 282 files changed, 37037 insertions(+), 0 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.gitignore	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,59 @@
+.hg
+.hgignore
+*.o
+*.cmi
+*.cmo
+*~
+keiko/interp.c
+keiko/keiko.h
+keiko/obx-t.a
+keiko/pplink
+keiko/ppx
+keiko/template.c
+lab1/a.k
+lab1/a.test
+lab1/a.x
+lab1/lexer.ml
+lab1/parser.ml
+lab1/parser.mli
+lab1/parser.output
+lab1/ppc
+lab2/a.k
+lab2/a.test
+lab2/a.x
+lab2/lexer.ml
+lab2/parser.ml
+lab2/parser.mli
+lab2/ppc
+lab3/a.k
+lab3/a.test
+lab3/a.x
+lab3/lexer.ml
+lab3/parser.ml
+lab3/parser.mli
+lab3/ppc
+lab4/b.out
+lab4/b.s
+lab4/b.test
+lab4/lexer.ml
+lab4/parser.ml
+lab4/parser.mli
+lab4/parser.output
+lab4/ppc
+lib/common.cma
+ppc/a.k
+ppc/a.test
+ppc/a.x
+ppc/lexer.ml
+ppc/parser.ml
+ppc/parser.mli
+ppc/parser.output
+ppc/ppc
+tools/nclex.ml
+tools/ncparse.ml
+tools/ncparse.mli
+tools/ncparse.output
+tools/nodexp
+tools/guest_rsa
+tools/pibake
+tools/sshconfig
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,52 @@
+syntax:glob
+*.o
+*.cmi
+*.cmo
+*.cma
+*~
+.git
+.gitignore
+keiko/interp.c
+keiko/keiko.h
+keiko/obx-t.a
+keiko/pplink
+keiko/ppx
+keiko/template.c
+lab1/a.k
+lab1/a.test
+lab1/a.x
+lab1/lexer.ml
+lab1/parser.ml
+lab1/parser.mli
+lab1/parser.output
+lab1/ppc
+lab2/lexer.ml
+lab2/parser.ml
+lab2/parser.mli
+lab2/ppc
+lab3/lexer.ml
+lab3/parser.ml
+lab3/parser.mli
+lab3/ppc
+lab4/lexer.ml
+lab4/parser.ml
+lab4/parser.mli
+lab4/parser.output
+lab4/ppc
+tools/nclex.ml
+tools/ncparse.ml
+tools/ncparse.mli
+tools/ncparse.output
+tools/nodexp
+lab4/b.out
+lab4/b.s
+lab4/b.test
+lab2/a.k
+lab2/a.test
+lab2/a.x
+lab3/a.k
+lab3/a.test
+lab3/a.x
+tools/guest_rsa
+tools/pibake
+tools/sshconfig
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,12 @@
+This directory contains the lab materials for Compilers.
+
+The following subdirectories exist:
+
+    lab1        Code for Lab 1 -- expressions and statements
+    lab2        Code for Lab 2 -- arrays
+    lab3        Code for Lab 3 -- procedures
+    lab4        Code for Lab 4 -- machine code
+    keiko       Keiko bytecode interpreter
+    lib         Shared utility routines
+    tools       Tools for Lab 4
+    ppc         Complete picoPascal compiler for Keiko
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/Makefile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,64 @@
+# keiko/Makefile
+
+# Config stuff
+AR = ar
+RANLIB = ranlib
+CFLAGS = -g -O2
+RTFLAGS = $(CFLAGS) -fno-strict-aliasing
+GC_PAGESIZE = 4096
+# End
+
+include config.mk
+
+all :: ppx pplink
+
+ALL_CFLAGS = $(CFLAGS) -Wall $(INCLUDE)
+ALL_RTFLAGS = $(RTFLAGS) -Wall $(HOST_DEFINES) $(INCLUDE)
+
+PPLINK = oblink.o linker.o symtab.o template.o util.o
+pplink : $(PPLINK) 
+	$(CC) $(CFLAGS) -o $@ $^
+
+$(PPLINK) : %.o : %.c
+	$(CC) $(ALL_CFLAGS) -c $< -o $@
+
+COMMON = support.o loader.o gc0.o dynlink.o
+PACK = $(AR) cr $@ $^ && $(RANLIB) $@
+
+ppx: obx-t.a lib.o
+	$(CC) $(ALL_RTFLAGS) $^ -o $@
+
+obx-t.a : interp-t.o xmain-t.o trace.o $(COMMON);		$(PACK)
+
+# Cancel default rule
+%.o: %.c
+
+xmain.o xmain-t.o oblink.o: CFLAGS += -DREVID=\"compilers\" 
+
+interp.o trace.o lib.o $(COMMON): %.o : %.c
+	$(CC) $(ALL_RTFLAGS) -c $< -o $@
+
+%-t.o : %.c
+	$(CC) $(ALL_RTFLAGS) -DTRACE -c $< -o $@
+
+
+## Cleanup
+
+# clean: remove all object files
+clean:
+	rm -f pplink ppx *.[ao]
+
+.DELETE_ON_ERROR:
+
+###
+
+support.o interp.o interp-t.o interp-p.o interp-d.o profile.o \
+xmain.o xmain-t.o xmain-p.o xmain-d.o xmain-j.o debug.o \
+trace.o loader.o jit.o jitlab.o gc0.o: \
+	obx.h obcommon.h config.h exec.h
+
+interp.o interp-t.o xmain.o xmain-t.o trace.o: \
+	keiko.h
+
+linker.o oblink.o symtab.o template.o util.o: \
+	oblink.h obcommon.h config.h exec.h util.h keiko.h
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/config.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,179 @@
+/* keiko/config.h */
+/* Copyright (c) 2017 J. M. Spivey */
+
+/* Define if building universal (internal helper macro) */
+/* #undef AC_APPLE_UNIVERSAL_BUILD */
+
+/* Define to set up for debugging */
+#define DEBUG 1
+
+/* Directory separator in file names */
+#define DIRSEP "/"
+
+/* Extension for dynamic libraries */
+#define DLEXT ".so"
+
+/* Define if dynamic linking enabled */
+/* #undef DYNLINK */
+
+/* Define to 1 if you have the `clock' function. */
+#define HAVE_CLOCK 1
+
+/* Define to 1 if you don't have `vprintf' but do have `_doprnt.' */
+/* #undef HAVE_DOPRNT */
+
+/* Define to 1 if you have the `getopt_long_only' function. */
+#define HAVE_GETOPT_LONG_ONLY 1
+
+/* Define to 1 if you have the `getpagesize' function. */
+#define HAVE_GETPAGESIZE 1
+
+/* Define to 1 if you have the `gettimeofday' function. */
+#define HAVE_GETTIMEOFDAY 1
+
+/* Define if indexed jumps work. */
+#define HAVE_INDEXED_JUMPS 1
+
+/* Define to 1 if you have the <inttypes.h> header file. */
+#define HAVE_INTTYPES_H 1
+
+/* Define to 1 if you have the <memory.h> header file. */
+#define HAVE_MEMORY_H 1
+
+/* Define to 1 if you have the `mmap' function. */
+#define HAVE_MMAP 1
+
+/* Define to 1 if you have the `sigprocmask' function. */
+#define HAVE_SIGPROCMASK 1
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#define HAVE_STDINT_H 1
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#define HAVE_STDLIB_H 1
+
+/* Define to 1 if you have the `stpcpy' function. */
+#define HAVE_STPCPY 1
+
+/* Define to 1 if you have the <strings.h> header file. */
+#define HAVE_STRINGS_H 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if you have the `strtoul' function. */
+#define HAVE_STRTOUL 1
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#define HAVE_SYS_STAT_H 1
+
+/* Define to 1 if you have the <sys/time.h> header file. */
+#define HAVE_SYS_TIME_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#define HAVE_SYS_TYPES_H 1
+
+/* Define to 1 if you have the `time' function. */
+#define HAVE_TIME 1
+
+/* Define to 1 if you have the <time.h> header file. */
+#define HAVE_TIME_H 1
+
+/* Define to 1 if you have the <unistd.h> header file. */
+#define HAVE_UNISTD_H 1
+
+/* Define to 1 if you have the `vprintf' function. */
+#define HAVE_VPRINTF 1
+
+/* Define for Linux */
+#define LINUX 1
+
+/* Log2 of page size */
+#define LOG_PAGESIZE 12
+
+/* Define for 64-bit runtime with 32-bit pointers */
+/* #undef M64X32 */
+
+/* Define to enable hacks for MacOS X */
+/* #undef MACOS */
+
+/* Magic number for trailer */
+#define MAGIC "OBCX"
+
+/* Reboot FPU for each primitive */
+/* #undef NEED_FPINIT */
+
+/* Attribute for functions that don't return */
+#define NORETURN __attribute__ ((noreturn))
+
+/* Define to the address where bug reports for this package should be sent. */
+#define PACKAGE_BUGREPORT "mike@cs.ox.ac.uk"
+
+/* Define to the full name of this package. */
+#define PACKAGE_NAME "obc"
+
+/* Define to the full name and version of this package. */
+#define PACKAGE_STRING "obc 3.1alpha"
+
+/* Define to the one symbol short name of this package. */
+#define PACKAGE_TARNAME "obc"
+
+/* Bug tracker */
+#define PACKAGE_TRACKER "https://bitbucket.org/Spivey/obc-3/issues"
+
+/* Define to the home page for this package. */
+#define PACKAGE_URL ""
+
+/* Define to the version of this package. */
+#define PACKAGE_VERSION "3.1alpha"
+
+/* Page size */
+#define PAGESIZE 4096
+
+/* Version signature for symbol tables */
+#define SIG 0x00030190
+
+/* Define to 1 if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Attribute for unused variables */
+#define UNUSED __attribute__ ((unused))
+
+/* Whether to flush the cache */
+/* #undef USE_FLUSH */
+
+/* Whether to use inet sockets for the debugger */
+/* #undef USE_INET */
+
+/* Whether to call mprotect from JIT */
+#define USE_MPROTECT 1
+
+/* Define to enable hacks for Windows */
+/* #undef WINDOWS */
+
+/* Whether to include specials for the compilers course */
+#define SPECIALS 1
+
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+   significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+#  define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+/* #  undef WORDS_BIGENDIAN */
+# endif
+#endif
+
+/* Define to 1 if the X Window System is missing or not being used. */
+/* #undef X_DISPLAY_MISSING */
+
+/* Define to empty if `const' does not conform to ANSI C. */
+/* #undef const */
+
+/* Define to `__inline__' or `__inline' if that's what the C compiler
+   calls it, or to nothing if 'inline' is not supported under any name.  */
+#ifndef __cplusplus
+/* #undef inline */
+#endif
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/config.mk	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,21 @@
+# Choose C compiler depending on host type
+
+HOST := $(shell uname -s)-$(shell uname -m)
+
+CC-Linux-i686 = gcc
+CC-Linux-x86_64 = gcc
+CC-Darwin-i386 = gcc -m32
+CC-Darwin-x86_64 = gcc -m32
+CC-Linux-armv6l = gcc
+CC-Linux-armv7l = gcc
+
+DEF-Linux-x86_64 = -DM64X32
+
+_CC := $(CC-$(HOST))
+HOST_DEFINES = $(DEF-$(HOST))
+
+ifndef _CC
+    $(error Can't configure for host type $(HOST))
+endif
+
+CC = $(_CC) -std=gnu99
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/dynlink.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,261 @@
+/*
+ * dynlink.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+/*
+Initially, the procedure descriptor for each such primitive has the
+trap handler |dltrap| as its interpreter, and the CP_CODE field of
+the descriptor points to the name of the primitive as a string.
+When the primitive is first called, the |dltrap| primitive looks up
+the symbol and binds the primitive to its value for future use.
+Finally, it calls the newly-loaded primitive to complete the first
+call.
+
+Function |load_lib| loads a dynamic library.  Each Oberon module that
+links to a dynamic library should call |DynLink.Load("path")| 
+in its initialization part.
+*/
+
+#include "obx.h"
+
+#ifdef DYNLINK
+
+#ifndef __USE_GNU
+#define __USE_GNU
+#endif
+#include <dlfcn.h>
+
+#ifdef USEFFI
+#include <ffi.h>
+#endif
+
+void load_lib(char *fname) {
+     char buf[128];
+        
+     /* If the library name starts with '@', look in the OBC lib directory 
+        and append the extension ".so" or ".dylib" au chois */
+     if (fname[0] == '@') {
+          char *dir = getenv("OBC_LIB");
+          if (dir == NULL) dir = libpath;
+          if (dir == NULL) panic("no runtime library");
+          strcpy(buf, dir);
+          strcat(buf, "/");
+          strcat(buf, fname+1);
+          strcat(buf, DLEXT);
+          fname = buf;
+     }
+
+     /* Load the library */
+     if (dlopen(fname, RTLD_LAZY|RTLD_GLOBAL) == NULL) 
+          panic(dlerror());
+}
+
+#ifdef USEFFI
+#define MAXP 16
+
+typedef struct {
+     void (*fun)(void);
+     ffi_cif cif;
+} wrapper;
+
+static ffi_type *ffi_decode(char c) {
+     switch (c) {
+     case 'C':
+     case 'I':
+          return &ffi_type_sint32;
+     case 'L':
+          return &ffi_type_sint64;
+     case 'F':
+          return &ffi_type_float;
+     case 'D':
+          return &ffi_type_double;
+     case 'P':
+     case 'Q':
+     case 'X':
+          return &ffi_type_pointer;
+     case 'V':
+          return &ffi_type_void;
+     default:
+          panic("Bad type %c", c);
+          return NULL;
+     }
+}
+
+void dlstub(value *bp) {
+     value *cp = valptr(bp[CP]);
+     char *tstring = (char *) pointer(cp[CP_CODE]);
+
+     ffi_raw avals[MAXP], rval[2];
+     int i, p = 0, q = 0;
+     double d; longint z;
+     
+     FPINIT;
+
+     for (i = 0; tstring[i+1] != '\0'; i++) {
+          switch (tstring[i+1]) {
+          case 'C':
+               avals[q].sint = align_byte(bp[HEAD+p].i);
+               p += 1; q += 1; break;
+          case 'I':
+               avals[q].sint = bp[HEAD+p].i;
+               p += 1; q += 1; break;
+          case 'L':
+               z = get_long(&bp[HEAD+p]);
+               memcpy(avals[q].data, &z, sizeof(longint));
+               p += 2; q += sizeof(longint)/sizeof(ffi_raw); break;
+          case 'F':
+               avals[q].flt = bp[HEAD+p].f;
+               p += 1; q += 1; break;
+          case 'D':
+               d = get_double(&bp[HEAD+p]);
+               memcpy(avals[q].data, &d, sizeof(double));
+               p += 2; q += sizeof(double)/sizeof(ffi_raw); break;
+          case 'P':
+               avals[q].ptr = pointer(bp[HEAD+p]);
+               p += 1; q += 1; break;
+          case 'X':
+               avals[q].ptr = pointer(bp[HEAD+p]);
+               p += 2; q += 1; break;
+          case 'Q':
+               avals[q].ptr = ptrcast(uchar, get_long(&bp[HEAD+p]));
+               p += 2; q += 1; break;
+#ifdef SPECIALS
+          case 'S':
+               /* Static link for compilers course -- ignored */
+               p += 1; break;
+#endif
+          default:
+               panic("Bad type 2 %c", tstring[i+1]);
+          }
+     }
+
+     wrapper *w = (wrapper *) pointer(cp[CP_CONST]);
+     ffi_raw_call(&w->cif, w->fun, rval, avals);
+     
+     switch (tstring[0]) {
+     case 'C':
+     case 'I':
+          ob_res.i = rval->sint;
+          break;
+     case 'L':
+          memcpy(&z, rval, sizeof(longint));
+          put_long(&ob_res, z);
+          break;
+     case 'F':
+          ob_res.f = rval->flt;
+          break;
+     case 'D':
+          memcpy(&d, rval, sizeof(double));
+          put_double(&ob_res, d);
+          break;
+     case 'P':
+          ob_res.a = rval->uint;
+          break;
+     case 'Q':
+          put_long(&ob_res, (ptrtype) rval->ptr);
+          break;
+     case 'V':
+          break;
+     default:
+          panic("Bad type 3");
+     }
+}
+#endif
+
+primitive *find_prim(char *name) {
+     return (primitive *) dlsym(RTLD_DEFAULT, name);
+}
+
+#else
+
+void load_lib(char *fname) {
+}
+
+primitive *find_prim(char *name) {
+     int i;
+
+     for (i = 0; primtab[i].p_name != NULL; i++) {
+          if (strcmp(name, primtab[i].p_name) == 0)
+               return primtab[i].p_prim;
+     }
+
+     return NULL;
+}
+
+#endif
+
+void dltrap(value *bp) {
+     value *cp = valptr(bp[CP]);
+     char *tstring = (char *) pointer(cp[CP_CODE]);
+     char *name = tstring + strlen(tstring) + 1;
+     primitive *prim = NULL;
+
+     if (tstring[0] == '*')
+          prim = find_prim(name);
+     else {
+          /* Look for a static wrapper */
+          char primname[32];
+          sprintf(primname, "P_%s", name);
+          prim = find_prim(primname);
+     }
+
+     if (prim != NULL) {
+          cp[CP_PRIM].a = wrap_prim(prim);
+          (*prim)(bp);
+          return;
+     }
+
+#ifdef DYNLINK
+#ifdef USEFFI
+     /* Build a wrapper with FFI */
+     void (*fun)(void) = (void(*)(void)) dlsym(RTLD_DEFAULT, name);
+
+     if (fun != NULL && tstring[0] != '*') {
+          int np = strlen(tstring)-1;
+          ffi_type *rtype = ffi_decode(tstring[0]);
+          ffi_type **atypes =
+               (ffi_type **) scratch_alloc(np * sizeof(ffi_type *));
+          for (int i = 0; tstring[i+1] != '\0'; i++)
+               atypes[i] = ffi_decode(tstring[i+1]);
+
+          wrapper *w = (wrapper *) scratch_alloc(sizeof(wrapper));
+          w->fun = fun;
+          ffi_prep_cif(&w->cif, FFI_DEFAULT_ABI, np, rtype, atypes);
+
+          cp[CP_PRIM].a = dynstub;
+          cp[CP_CONST].a = address(w);
+
+          dlstub(bp);
+          return;
+     }
+#endif
+#endif
+
+     panic("Couldn't find primitive %s", name);
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/exec.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,96 @@
+/*
+ * exec.h
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+/* 
+The binary file output by the linker and input by the run-time
+interpreter consists of several segments followed by a trailer that
+describes the layout of the segments.  The segments may be preceded
+by a block of arbitrary data, but they must appear in the following order:
+
+    CODE, DATA, RELOC, SYMTAB
+
+By using a trailer rather than a header, we allow for a binary file
+also to be a valid file in another format that uses a header -- like
+the executable format of most operating systems including various
+Unixes and MS--DOS.  In that format, our code is just junk beyond the
+end of the file, and it is usually ignored.  So we can make
+self-contained executables by concatenating the interpreter with the
+code for a program. This idea was stolen from CAML Light.  
+*/
+
+/* Codes for the segments: they must appear in the object file
+   in this order */
+#define NSEGS 4
+#define S_CODE 0                /* Bytecode */
+#define S_DATA 1                /* Initialized data */
+#define S_BSS 2                 /* Below stack storage */
+#define S_STACK 3               /* Stack */
+
+typedef uchar word4[4];
+
+typedef struct {
+     word4 magic;               /* Magic number 'OBCX' */
+     word4 sig;                 /* Signature */
+     word4 primsig;             /* Checksum of primitives */
+     word4 start;               /* Offset of data start from end of file */
+     word4 entry;               /* Entry point */
+     word4 gcmap;               /* Global pointer map */
+     word4 libdir;              /* Location of dynamic libraries */
+     word4 segment[NSEGS];      /* Segment sizes */
+     word4 nprocs, nmods, nsyms; /* No. of procs, modules, symbols */
+} trailer;
+
+
+/* Layout of relocation data */
+#define WORD_SIZE 4
+#define CODES_PER_WORD 16
+#define BITS_PER_CODE 2
+#define CODE_MASK ((1 << BITS_PER_CODE) - 1)
+
+#define reloc_bits(buf, i) (buf[(i)/CODES_PER_WORD] >> \
+        ((i) % CODES_PER_WORD * BITS_PER_CODE) & CODE_MASK)
+
+/* Relocation codes */
+#define R_WORD 0
+#define R_DATA 1
+#define R_CODE 2
+#define R_SUBR 3
+
+/* Symbol tags */
+#define X_NONE 0
+#define X_MODULE 1
+#define X_PROC 2
+#define X_DATA 3
+#define X_LINE 4
+#define X_SYM 5
+
+/* Fixed primitives */
+#define INTERP 0                /* Index of interpreter as primitive */
+#define DLTRAP 1                /* Index of dynlink trap */
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/gc0.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,80 @@
+/*
+ * gc0.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ *
+ * $Id: gc.c 1557 2010-01-24 20:59:31Z mike $
+ */
+
+/* keiko/gc0.c */
+/* Copyright (c) 2017 J. M. Spivey */
+
+#include "obx.h"
+
+#include <sys/mman.h>
+
+#ifndef MAP_ANONYMOUS
+#define MAP_ANONYMOUS MAP_ANON
+#endif
+
+#ifdef M64X32
+#define MAP_FLAGS MAP_PRIVATE|MAP_32BIT|MAP_ANONYMOUS
+#else
+#define MAP_FLAGS MAP_PRIVATE|MAP_ANONYMOUS
+#endif
+
+static void *get_memory(unsigned size) {
+     void *p = mmap(NULL, size, PROT_READ|PROT_WRITE,
+                    MAP_FLAGS, -1, 0);
+     if (p == MAP_FAILED) panic("Out of memory");
+     return p;
+}
+
+#define CHUNK 16384
+
+static unsigned char *alloc = NULL;
+static unsigned char *limit = NULL;
+
+#define roundup(x, n) (((x)+(n-1))&~(n-1))
+
+void *scratch_alloc(unsigned size) {
+     if (size % PAGESIZE == 0 || size > CHUNK)
+          return get_memory(roundup(size, PAGESIZE));
+     
+     if (alloc == NULL || size > limit - alloc) {
+          alloc = get_memory(CHUNK);
+          limit = alloc + CHUNK;
+     }
+
+     void *p = alloc;
+     alloc += size;
+     return p;
+}
+
+/* gc_init -- initialise everything */
+void gc_init(void) {
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/lib.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,62 @@
+/* lib.c */
+/* Copyright (c) 2017 J. M. Spivey */
+
+#include "primtab.h"
+
+int lib_argc(void) {
+     return saved_argc;
+}
+
+void lib_argv(int n, char *s) {
+     /* Buffer overflow waiting to happen */
+     strcpy(s, saved_argv[n]);
+}
+
+void lib_print_num(int n) {
+     printf("%d", n);
+}
+
+void lib_print_string(char *s) {
+     fputs(s, stdout);
+}
+
+void lib_print_char(char c) {
+     putchar(c);
+}
+
+static FILE *infile = NULL;
+
+int lib_open_in(char *name) {
+     FILE *f = fopen(name, "r");
+     if (f == NULL) return 0;
+     if (infile != NULL) fclose(infile);
+     infile = f;
+     return 1;
+}
+
+void lib_close_in(void) {
+     if (infile == NULL) return;
+     fclose(infile);
+     infile = NULL;
+}
+
+void lib_read_char(char *p) {
+     FILE *f = (infile == NULL ? stdin : infile);
+     int ch = fgetc(f);
+     *p = (ch == EOF ? 127 : ch);
+}
+
+#define PRIMS(direct, indirect, wrapper) \
+     wrapper(scratch_alloc, P, I) \
+     wrapper(lib_argc, I) \
+     wrapper(lib_argv, V, I, P) \
+     wrapper(lib_print_num, V, I) \
+     wrapper(lib_print_string, V, P) \
+     wrapper(lib_print_char, V, C) \
+     wrapper(lib_open_in, I, P) \
+     wrapper(lib_close_in, V) \
+     wrapper(lib_read_char, V, P) \
+     wrapper(exit, V, I)
+
+/* Using PPRIMTAB adds an offset to compensate for static links */
+PPRIMTAB(PRIMS)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/lib.k	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,38 @@
+! keiko/lib.c
+! Copyright (c) 2017 J. M. Spivey
+
+MODULE Lib 0 0
+ENDHDR
+
+! Primitives for labs 1--3
+PROC lib.print 0 0 0
+CONST 32
+CONST 0
+GLOBAL lib.print_char
+PCALL 1
+LDLW 16
+CONST 0
+GLOBAL lib.print_num
+PCALL 1
+RETURN
+END
+
+PROC lib.newline 0 0 0
+CONST 10
+CONST 0
+GLOBAL lib.print_char
+PCALL 1
+RETURN
+END
+
+! Primitives for ppc
+PRIMDEF lib.new scratch_alloc PSI
+PRIMDEF lib.open_in lib_open_in ISP
+PRIMDEF lib.close_in lib_close_in VS
+PRIMDEF lib.read_char lib_read_char VSP
+PRIMDEF lib.print_num lib_print_num VSI
+PRIMDEF lib.print_string lib_print_string VSP
+PRIMDEF lib.print_char lib_print_char VSC
+PRIMDEF lib.argc lib_argc IS
+PRIMDEF lib.argv lib_argv VSIP
+PRIMDEF lib.exit exit VSI
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/linker.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,900 @@
+/*
+ * linker.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 <ctype.h>
+#include "oblink.h"
+#include "keiko.h"
+
+static FILE *binfp;             /* File for code output */
+
+/* binwrite -- output code */
+static void binwrite(void *buf, int size) {
+     int UNUSED nwritten = fwrite(buf, 1, size, binfp);
+}
+
+/* hexchar -- convert character from two-digit hex */
+static char hexchar(char *s) {
+     char buf[3];
+
+     buf[0] = s[0]; buf[1] = s[1]; buf[2] = '\0';
+     return (char) strtoul(buf, NULL, 16);
+}
+
+static int iloc = 0, bloc = 0;  /* Sizes of code, bss segments */
+static int nmods = 0, nprocs = 0; /* Number of modules and procedures */
+static symbol this_module;      /* Current module */
+static symbol this_proc;        /* Current procedure */
+static int proc_start;          /* Start of procedure in dbuf */
+static int code_size;           /* Size of bytecode for procedure */
+
+/* Instructions are stored as 'phrases' in abuf, a doubly-linked list.
+   Each phrase has a tentative assignment of a template, which describes 
+   at least what arguments there should be; before the code is output, the
+   template may be replaced by one with bigger fields in order to make the 
+   arguments fit.  The code for a procedure is built up in abuf and output 
+   at the end of the procedure. */
+
+struct _phrase {                /* An instruction in the assembler */
+     const char *q_name;        /* Instruction name */
+     template q_templ;          /* Best estimate of template */
+     int q_arg[MAXARGS];        /* Arguments */
+     int q_addr;                /* Estimated address from start of proc */
+     symbol q_sym;              /* Symbol for this address */
+     phrase q_target;           /* Branch target */
+     phrase q_prev, q_next;     /* Links in the list */
+};
+
+phrase abuf;
+
+#define for_phrases(q) \
+     for (phrase q = abuf->q_next; q != abuf; q = q->q_next)    
+
+mempool pool;
+
+static phrase alloc_phrase(void) {
+     return (phrase) pool_alloc(&pool, sizeof(struct _phrase));
+}
+
+static void init_abuf(void) {
+     pool_reset(&pool);
+     abuf = alloc_phrase();
+     abuf->q_name = (char *) "*dummy*";
+     abuf->q_templ = NULL;
+     abuf->q_addr = 0;
+     abuf->q_sym = NULL;
+     abuf->q_target = NULL;
+     abuf->q_prev = abuf->q_next = abuf;
+}
+
+static growdecl(dbuf);
+#define dbuf growbuf(dbuf, uchar)
+#define dloc growsize(dbuf)
+
+static growdecl(rbuf);
+#define rbuf growbuf(rbuf, unsigned)
+#define rloc growsize(rbuf)
+
+static growdecl(prims);
+#define prims growbuf(prims, int)
+#define nprims growsize(prims)
+
+/* relocate -- record relocation bits */
+void relocate(int loc, int bits) {
+     /* Each byte of relocation info covers CODES_PER_BYTE words */
+     int index = loc/(WORD_SIZE * CODES_PER_WORD);
+     int shift = loc/WORD_SIZE % CODES_PER_WORD * BITS_PER_CODE;
+
+     if (rloc < index+1) rloc = index+1;
+     buf_grow(rbuf);
+     rbuf[index] = (rbuf[index] & ~(CODE_MASK << shift)) | (bits << shift);
+#ifdef DEBUG
+     if (dflag) printf("Reloc %d %d %#08x\n", loc, bits, rbuf[index]);
+#endif
+}
+
+static void put_value(int addr, int value, int reloc) {
+     /* We carefully store all 4-byte values in dbuf in
+        machine-independent byte order: little-endian even if the host
+        is a big-endian machine. The value reloc determines how the
+        value should be relocated when the program is loaded by obx. */
+     put4(&dbuf[addr], value);
+     relocate(addr, reloc);
+}
+
+static int const_value(char *s) {
+     /* We must allow both signed and unsigned (especially hex)
+        constants, so negative numbers must be treated separately.
+        Note that strtol is specified to truncate to MAXINT on
+        overflow, not to operate mod 2^32. */
+
+     if (s == NULL)
+          return 0;
+     else if (s[0] == '-')
+          return strtol(s, NULL, 0);
+     else
+          return strtoul(s, NULL, 0);
+}
+
+static void data_value(int value, int reloc) {
+     buf_grow(dbuf);
+     put_value(dloc, value, reloc);
+     dloc += 4;
+}
+
+static void data_word(char *s) {
+     buf_grow(dbuf);
+     if (s == NULL || isdigit((int) s[0]) || s[0] == '-')
+          put_value(dloc, const_value(s), R_WORD);
+     else
+          use_global(find_symbol(s), dbuf, dloc);
+     dloc += 4;
+}
+
+static void put_string(char *str) {
+     char *s = str;
+     do { 
+          buf_grow(dbuf); 
+          dbuf[dloc++] = *s;
+     } while (*s++ != '\0');
+}
+
+
+/* Constant pool */
+
+static growdecl(const_sym);
+#define const_sym growbuf(const_sym, symbol)
+#define nconsts growsize(const_sym)
+
+#define get_const(n) get4(dbuf + proc_start + 4 * (CP_CONST+(n))) 
+
+static int find_const(int value, symbol sym) {
+     int i;
+
+     for (i = 0; i < nconsts; i++) {
+          if (sym == NULL
+              ? (const_sym[i] == NULL && get_const(i) == value)
+              : const_sym[i] == sym)
+               return i;
+     }
+
+     i = nconsts++;
+     buf_grow(const_sym);
+     const_sym[i] = sym;
+     buf_grow(dbuf);
+
+     if (sym == NULL)
+          put_value(dloc, value, R_WORD);
+     else
+          use_global(sym, dbuf, dloc);
+
+     dloc += 4;
+     return i;
+}
+
+static int find_dconst(int val0, int val1) {
+     int i;
+
+     for (i = 0; i < nconsts-1; i++) {
+          if (const_sym[i] == NULL && const_sym[i+1] == NULL
+              && get_const(i) == val0 && get_const(i+1) == val1)
+               return i;
+     }
+
+     i = nconsts; nconsts += 2;
+     buf_grow(const_sym);
+     const_sym[i] = const_sym[i+1] = NULL;
+     data_value(val0, R_WORD);
+     data_value(val1, R_WORD);
+
+     return i;
+}
+
+static int make_const(char *s) {
+     if (isdigit((int) s[0]) || s[0] == '-')
+          return find_const(const_value(s), NULL);
+     else
+          return find_const(0, find_symbol(s));
+}
+
+
+/* Instruction templates */
+
+/* find_template -- find first template for instruction */
+static template find_template(const char *name) {
+     const char *s = name;
+     int q = 0;
+     char ch;
+
+     /* The templates are organised in a trie */
+
+     do {
+          ch = *s++ & 0x7f;
+
+          if (templ_check[q+ch] != ch) 
+               panic("*no template found for %s", name);
+
+          q = templ_trie[q+ch];
+     } while (ch != '\0');
+
+     return &templates[q];
+}
+
+/* fits -- test if an integer fits in a certain number of bits */
+static mybool fits(int x, int n) {
+     int max = 1 << (n-1);
+     return (-max <= x && x < max);
+}
+
+/* fix_labels -- compute target for jump */
+static void fix_labels(phrase q) {
+     const char *p = q->q_templ->t_pattern;
+     
+     for (int j = 0; p[j] != '\0'; j++)
+          if (p[j] == 'R' || p[j] == 'S') 
+               q->q_target = find_label(q->q_arg[j]);
+}
+
+/* displacement -- calculate branch displacement */
+static int displacement(phrase q) {
+     /* Phrase |q| is a branch instruction.  The signed displacement
+        is the distance from the opcode to the target. */
+     return (q->q_target->q_addr - q->q_addr);
+}
+
+/* match -- test whether a template matches its arguments */
+static mybool match(phrase q, template t) {
+     /* Just check the last operand */
+     int n = strlen(t->t_pattern);
+     const char *p = t->t_pattern;
+     int *a = q->q_arg;
+
+     if (n == 0) return TRUE;
+
+     switch (p[n-1]) {
+     case 'N':
+          { int val = a[n-1];
+            return (val >= t->t_lo && val <= t->t_hi 
+                    && (val - t->t_lo) % t->t_step == 0); }
+     case '1':
+     case 'K':
+          return fits(a[n-1], 8);
+     case '2':
+     case 'L':
+          return fits(a[n-1], 16);
+     case 'R':
+          return fits(displacement(q), 16);
+     case 'S':
+          return fits(displacement(q), 8);
+     default:
+          return TRUE;
+     }
+}
+
+#ifdef DEBUG
+static void print_args(phrase q) {
+     const char *patt = q->q_templ->t_pattern;
+
+     for (int j = 0; patt[j] != '\0'; j++) {
+          switch (patt[j]) {
+          case '1':
+          case '2':
+          case 'N':
+          case 'K':
+          case 'L':
+               printf(" %d", q->q_arg[j]); break;
+          case 'R':
+          case 'S':
+               printf(" %+d", displacement(q)); break;
+          default:
+               printf(" ???");
+          }
+     }
+}
+#endif
+
+static int get_arg(char tmpl, char *rand, template t, int cxt[]) {
+     if (rand[0] == '$' && cxt != NULL)
+          return cxt[rand[1] - 'a'];
+
+     switch (tmpl) {
+     case '1':
+     case '2':
+     case 'N':
+          if (isdigit((int) rand[0]) || rand[0] == '-')
+               return const_value(rand);
+          else
+               return sym_value(find_symbol(rand));
+
+     case 'R':
+     case 'S':
+          return make_label(find_symbol(rand));
+
+     case 'K':
+     case 'L':
+          return make_const(rand);
+
+     default:
+          panic("*bad template %c for %s", tmpl, t->t_name);
+          return 0;
+     }
+}
+
+/* do_template -- enter an instruction */
+static phrase do_template(template t, char *rands[], phrase rgt, int cxt[]) { 
+     /* Template t determines the number and kinds of operands for the
+        instruction; depending on the values of the operands, it may or
+        may not end up actually matching the instruction. */
+
+     phrase q = alloc_phrase();
+     phrase lft = rgt->q_prev;
+     const char *patt = t->t_pattern;
+
+     q->q_name = t->t_name;
+     q->q_templ = t;
+     for (int i = 0; patt[i] != '\0'; i++) 
+          q->q_arg[i] = get_arg(patt[i], rands[i], t, cxt);
+     q->q_addr = 0;
+     q->q_sym = NULL;
+     q->q_target = NULL;
+     q->q_prev = lft; q->q_next = rgt;
+     lft->q_next = rgt->q_prev = q;
+     return q;
+}
+
+/* expand -- replace macro by its expansion */
+static phrase expand(phrase q) {
+     static char buf[128];
+     char *words[10];
+     template t = q->q_templ;
+     phrase r = q->q_prev, q1;
+
+     for (int i = 0; t->t_macro[i] != NULL; i++) {
+          strcpy(buf, t->t_macro[i]);
+          int n = split_line(buf, words);
+          template t1 = find_template(words[0]);
+          if (strlen(t1->t_pattern) != n-1 || t->t_size < 0) 
+               panic("*macro expansion failed");
+
+          /* Insert expansion before original phrase */
+          q1 = do_template(t1, &words[1], q, q->q_arg);
+          fix_labels(q1);
+     }
+
+     /* Delete the original */
+     q->q_prev->q_next = q->q_next;
+     q->q_next->q_prev = q->q_prev;
+
+     return r->q_next;
+}     
+
+/* check_matches -- revise choice of templates, return TRUE if ok already */
+static mybool check_matches(void) {
+     mybool ok = TRUE;
+
+     for (phrase q = abuf->q_next; q != abuf; ) {
+          template t = q->q_templ;
+
+          if (t->t_macro[0] != NULL) {
+               /* A macro instruction: expand it */
+               q = expand(q);
+               ok = FALSE;
+          } else if (! match(q, t)) {
+               t++;
+
+               if (t >= &templates[NTEMPLATES] || t->t_name != NULL) {
+                    panic("*no template fits %s", q->q_name);
+               }
+
+               q->q_templ = t;
+               ok = FALSE;
+          } else {
+               q = q->q_next;
+          }
+     }
+       
+     return ok;
+}
+
+/* assemble -- assemble instructions */
+static void assemble(void) {
+     mybool ok;
+     int trial = 0;
+
+     for_phrases (q) fix_labels(q);
+
+     /* A tentative assignment of templates has already been computed,
+        but the arguments may not fit in the field sizes assigned.  So
+        now we repeatedly revise the assignment until all arguments fit.
+        Changing the assignment will increase the size of some instructions,
+        perhaps making branches longer so that they no longer fit either
+        -- that's why iteration is necessary.
+
+        The invariant is that there is no feasible choice of templates that
+        makes any instruction smaller than it is in the current assignment.
+        The variant is the total number of templates that remain to be tried.
+        Correctness of the algorithm follows from the fact that making one 
+        instruction larger cannot allow another to be smaller. */
+
+     do {
+          int a = 0;
+          trial++;
+#ifdef DEBUG
+          if (dflag > 0)
+               printf("Checking templates (pass %d)\n", trial);
+#endif    
+
+          /* Calculate address of each instruction */
+          for_phrases (q) {
+               q->q_addr = a;
+               a += q->q_templ->t_size;
+          }
+
+          code_size = a;
+          ok = check_matches(); /* Revise template choices */
+     } while (!ok);
+}
+
+/* make_binary -- output binary code */
+static void make_binary(void) {
+     for_phrases (q) {
+          template t = q->q_templ;
+          const char *p = t->t_pattern;
+          int *a = q->q_arg;
+
+#ifdef DEBUG
+          if (dflag > 0) {
+               printf("%d: %s(%s)", q->q_addr, q->q_name, p);
+               print_args(q);
+               printf("\n");
+          }
+#endif
+
+          if (q->q_sym != NULL)
+               def_global(q->q_sym, CODE, iloc + q->q_addr, X_LINE);
+
+          if (p[0] == 'N')
+               write_int(1, t->t_op + (a[0] - t->t_lo)/t->t_step);
+          else if (t->t_oplen > 0) 
+               binwrite(&t->t_op, t->t_oplen);
+
+          for (int j = 0; p[j] != '\0'; j++) {
+               switch (p[j]) {
+               case 'N':
+                    break;
+               case '1': 
+               case 'K':
+                    write_int(1, a[j]); break;
+               case '2':
+               case 'L': 
+                    write_int(2, a[j]); break;
+               case 'R': 
+                    write_int(2, displacement(q)); break;
+               case 'S': 
+                    write_int(1, displacement(q)); break;
+               default:  
+                    panic("*bad template %c", p[j]);
+               }
+          }
+     }
+}
+
+/* MARK pseudo-instructions generate no code, and are used to place labels,
+   line numbers, etc. */
+struct _template mark = {
+     "*MARK*", "", 0, 0, 0, 0, 0, 0, { NULL }
+};
+
+static phrase put_mark(symbol s) {
+     phrase q = do_template(&mark, NULL, abuf, NULL);
+     q->q_sym = s;
+     return q;
+}
+
+/* const_head -- start of constant pool */
+static void const_head(int prim, int code, int reloc, 
+                       int frame, int stack, char *map) {
+     data_value(prim, R_SUBR);  /* Primitive */
+     data_value(code, reloc);   /* Entry point */
+     data_value(0, R_WORD);     /* Code size */
+     data_value(frame, R_WORD); /* Frame size in words */
+     data_value(stack, R_WORD); /* Stack size in words */
+     data_word(map);            /* Frame map */
+     data_value(0, R_WORD);     /* Stack map table */
+}
+
+typedef struct {
+     phrase sm_addr;            /* Pointer to the JPROC instruction */
+     char *sm_text;             /* Symbol or numeric value */
+} stackmap;
+
+static growdecl(smbuf);
+#define smbuf growbuf(smbuf, stackmap)
+#define smp growsize(smbuf)
+
+/* fix_stackmaps -- fix up the stack maps for the current procedure */
+static void fix_stackmaps(void) {
+     if (smp == 0) return;
+
+     /* Fill in the address of the table in the constant pool */
+     put_value(proc_start + 4*CP_STKMAP, dloc, R_DATA);
+
+     /* Create the table itself */
+     for (int i = 0; i < smp; i++) {
+          stackmap *sm = &smbuf[i];
+
+          /* The return address for the call: '+1' to allow for the space
+             occupied by the JPROC instruction */
+          data_value(iloc + sm->sm_addr->q_addr + 1, R_CODE);
+
+          /* The stack map */
+          data_word(sm->sm_text);
+     }
+
+     data_value(0, R_WORD);
+}
+
+typedef struct {
+     int h_begin, h_end;        /* Scope of handler */
+     symbol h_excep;            /* Exception */
+     phrase h_body;             /* Handler code */
+} handler;
+
+/* check_inproc -- panic if not in a procedure */
+static void check_inproc(const char *opcode) {
+     if (this_proc == NULL)
+          panic("*%s occurs outside any procedure", opcode);
+}
+
+/* do_directive -- process a directive */
+static void do_directive(const char *dir, int n, char *rands[], int nrands) {
+     union { int n; float f; } fcvt;
+     dblbuf dcvt;
+     int v;
+
+     switch (n) {
+     case D_LABEL:
+          check_inproc(dir);
+          /* Each label is defined as the |abuf| index of its target */
+          def_label(find_symbol(rands[0]), put_mark(NULL));
+          break;
+
+     case D_STRING:
+          for (int i = 0; rands[0][2*i] != '\0'; i++) {
+               buf_grow(dbuf);
+               dbuf[dloc++] = hexchar(&rands[0][2*i]);
+          }
+          dloc = align(dloc, 4);
+          break;
+
+     case D_CONST:
+          check_inproc(dir);
+          if ((isdigit((int) rands[0][0]) || rands[0][0] == '-')
+              && fits(v = const_value(rands[0]), 16))
+               gen_inst("PUSH %d", v);
+          else
+               gen_inst("LDKW %d", make_const(rands[0]));
+          break;
+
+     case D_GLOBAL:
+          check_inproc(dir);
+          gen_inst("LDKW %d", make_const(rands[0]));
+          break;
+
+     case D_FCONST:
+          check_inproc(dir);
+          fcvt.f = atof(rands[0]);
+          gen_inst("LDKF %d", find_const(fcvt.n, NULL));
+          break;
+
+     case D_DCONST:
+          check_inproc(dir);
+          dcvt.d = atof(rands[0]);
+          gen_inst("LDKD %d", find_dconst(dcvt.n.lo, dcvt.n.hi));
+          break;
+
+     case D_QCONST:
+          check_inproc(dir);
+          dcvt.q = strtoll(rands[0], NULL, 0);
+          gen_inst("LDKQ %d", find_dconst(dcvt.n.lo, dcvt.n.hi));
+          break;
+
+     case D_WORD:
+          data_word(rands[0]);
+          break;
+
+     case D_GLOVAR:
+          def_global(find_symbol(rands[0]), BSS, bloc, X_DATA);
+          bloc = align(bloc + strtoul(rands[1], NULL, 0), 4);
+          break;
+
+     case D_MODULE:
+          nmods++;
+          this_module = find_symbol(rands[0]);
+          def_global(this_module, DATA, dloc, X_MODULE);
+          module_data(this_module, strtoul(rands[1], NULL, 0), 
+                      strtol(rands[2], NULL, 0));
+          break;
+
+     case D_PRIMDEF:
+          nprocs++;
+          dloc = align(dloc, 8);
+          buf_grow(prims);
+          prims[nprims++] = dloc;
+          def_global(find_symbol(rands[0]), DATA, dloc, X_PROC);
+          const_head(DLTRAP, dloc + 4*CP_CONST + 4, R_DATA, 0, 0, NULL);
+          data_value(0, R_WORD); // Pointer to access block
+          put_string(rands[2]);  // Type descriptor
+          put_string(rands[1]);  // Symbol name
+          dloc = align(dloc, 4);
+          break;
+
+     case D_PROC:
+          nprocs++;
+          dloc = align(dloc, 8);
+          this_proc = find_symbol(rands[0]);
+          proc_start = dloc;
+          def_global(this_proc, DATA, proc_start, X_PROC);
+          const_head(INTERP, iloc, R_CODE, atoi(rands[1]), 
+                     atoi(rands[2]), rands[3]);
+
+          init_abuf();
+          init_labels();
+          nconsts = 0;
+          smp = 0;
+          break;
+
+     case D_STKMAP:
+          /* Stack map for a procedure call */
+          check_inproc(dir);
+          buf_grow(smbuf);
+          smbuf[smp].sm_addr = put_mark(NULL);
+          smbuf[smp].sm_text = must_strdup(rands[0]);
+          smp++;
+          break;
+
+     case D_END:
+          /* End of procedure body */
+          check_inproc(dir);
+          assemble();           /* Finally choose templates */
+          fix_stackmaps();      /* Compile the stack maps */
+          make_binary();        /* Output the code */
+          put_value(proc_start + 4*CP_SIZE, code_size, R_WORD);
+          iloc += code_size;
+          this_proc = NULL;
+          break;
+
+     case D_IMPORT:
+     case D_ENDHDR:
+          /* Ignore directives that appear in the file header */
+          break;
+
+     case D_DEFINE:
+          def_global(find_symbol(rands[0]), DATA, dloc, X_DATA);
+          break;
+
+     case D_LINE:
+          check_inproc(dir);
+
+          if (gflag) {
+               char buf[64];
+               sprintf(buf, "%s.%s", sym_name(this_module), rands[0]);
+               put_mark(make_symbol(buf));
+          }
+
+          if (linecount) 
+               put_inst("LNUM", rands, nrands);
+
+          break;
+
+#ifdef SPECIALS
+     case D_PCALL:
+          check_inproc(dir);
+          gen_inst("CALL %d", atoi(rands[0])+1);
+          break;
+
+     case D_PCALLW:
+          check_inproc(dir);
+          gen_inst("CALLW %d", atoi(rands[0])+1);
+          break;
+#endif
+
+     default:
+          panic("*unknown directive %s (%d)", dir, n);
+     }
+}
+
+/* put_inst -- process one instruction or directive */
+void put_inst(const char *name, char *rands[], unsigned nrands) {
+     template t = find_template(name);
+
+     if (nrands != strlen(t->t_pattern)) {
+          fprintf(stderr, "Instruction: %s", name);
+          for (int i = 0; i < nrands; i++)
+               fprintf(stderr, " %s", rands[i]);
+          fprintf(stderr, ", File: %s\n", err_file);
+          panic("*%s needs %d operands, got %d", 
+                name, strlen(t->t_pattern), nrands);
+     }
+
+     if (t->t_size < 0)
+          do_directive(t->t_name, t->t_op, rands, nrands);
+     else {
+          check_inproc(name);
+          do_template(t, rands, abuf, NULL);
+     }
+}
+
+/* gen_inst -- generate an instruction from text */
+void gen_inst(const char *fmt, ...) {
+     char line[80];
+     char *words[10];
+     int nwords;
+
+     va_list ap;
+
+     va_start(ap, fmt);
+     vsprintf(line, fmt, ap);
+     strcat(line, "\n");
+     va_end(ap);
+
+     nwords = split_line(line, words);
+     put_inst(words[0], &words[1], nwords-1);
+}
+
+/* save_string -- save a string in the data segment */
+void save_string(const char *label, char *str) {
+     def_global(find_symbol(label), DATA, dloc, X_DATA);
+     put_string(str);
+     dloc = align(dloc, 4);
+}
+
+
+/* Object file output */
+
+static int start;               /* Starting offset of binary */
+
+void init_linker(char *outname, char *interp) {
+     buf_init(dbuf, INIT_XMEM, 4, uchar, "data");
+     buf_init(rbuf, INIT_XMEM/(WORD_SIZE * CODES_PER_WORD), 
+              1, unsigned, "relocation");
+     buf_init(smbuf, 16, 1, stackmap, "stack maps");
+     buf_init(const_sym, 256, 1, symbol, "constant pool");
+     buf_init(prims, 256, 1, int, "primitives");
+
+     binfp = fopen(outname, "wb");
+     if (binfp == NULL) {
+          perror(outname);
+          exit(2);
+     }
+
+     if (interp != NULL) 
+          fprintf(binfp, "#!%s\n", interp);
+
+     start = ftell(binfp);
+}
+
+/* end_linking -- write later parts of object file */
+void end_linking(void) {
+     trailer t;
+     int fsize, csize, symcount = 0, nwritten;
+     const char *magic = MAGIC;
+
+     csize = ftell(binfp) - start;
+     if (csize != iloc) {
+          fprintf(stderr, "csize = %d, iloc = %d\n", csize, iloc);
+          panic("*Wrong code size");
+     }
+
+     fix_data(dbuf, dloc);
+     rloc = (dloc/WORD_SIZE+CODES_PER_WORD-1)/CODES_PER_WORD;
+     buf_grow(rbuf);
+
+     binwrite(dbuf, dloc);
+     binwrite(rbuf, rloc * sizeof(unsigned));
+     if (!sflag) symcount = write_symtab();
+
+     fsize = ftell(binfp) + sizeof(trailer);
+
+#define sym_val(x) (known(x) ? sym_value(find_symbol(x)) : 0)
+
+     /* Trailer */
+     strncpy((char *) t.magic, magic, 4);
+     put4(t.sig, SIG);
+     put4(t.primsig, 0);
+     put4(t.start, start - fsize);
+     put4(t.entry, sym_val("MAIN"));
+     put4(t.gcmap, sym_val("GCMAP"));
+     put4(t.libdir, sym_val("LIBDIR"));
+     put4(t.segment[S_CODE], iloc);
+     put4(t.segment[S_DATA], dloc);
+     put4(t.segment[S_BSS], bloc);
+     put4(t.segment[S_STACK], stack_size);
+     put4(t.nprocs, (sflag ? 0 : nprocs));
+     put4(t.nmods, (sflag ? 0 : nmods));
+     put4(t.nsyms, symcount);
+     nwritten = fwrite(&t, sizeof(trailer), 1, binfp);
+     if (nwritten < 1)
+          panic("Couldn't write trailer");
+
+     fclose(binfp);
+}
+
+
+/* Routines for writing values in machine-independent byte order */
+
+void put_int(int n, uchar *buf, int x) {
+     for (int i = 0; i < n; i++)
+          buf[i] = (x >> (8*i)) & 0xff;
+}
+
+int get4(uchar *buf) {
+     return buf[0] + (buf[1] << 8) + (buf[2] << 16) + (buf[3] << 24);
+}
+
+void write_string(const char *s) {
+     binwrite((void *) s, strlen(s)+1);
+}
+
+void write_int(int n, int x) { 
+     uchar buf[4]; 
+     put_int(n, buf, x); 
+     binwrite(buf, n);
+}
+
+
+/* Primitive table */
+
+void dump_prims(void) {
+     printf("/* Generated by oblink */\n\n");
+     printf("#include \"primtab.h\"\n\n");
+     printf("#define PRIMS(direct, indirect, wrapper)");
+
+     for (int i = 0; i < nprims; i++) {
+          char *tstring = (char *) &dbuf[prims[i]] + 4*CP_CONST + 4;
+          char *name = tstring + strlen(tstring) + 1;
+
+          printf(" \\\n");
+          if (tstring[0] == '*')
+               /* Declare a direct primitive */
+               printf("     direct(%s)", name);
+          else {
+               /* Build a wrapper */
+               char *mac = (isupper(name[0]) ? "indirect" : "wrapper");
+               printf("     %s(%s", mac, name);
+               for (int i = 0; tstring[i] != '\0'; i++)
+                    printf(", %c", tstring[i]);
+               printf(")");
+          }
+     }
+
+     printf("\n\n");
+     printf("PRIMTAB(PRIMS)");
+}
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/loader.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,291 @@
+/*
+ * loader.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 "obx.h"
+#include "keiko.h"
+#include "exec.h"
+
+static FILE *binfp;
+
+static int binread(void *buf, int size) {
+     return fread(buf, 1, size, binfp);
+}
+
+static int bingetc(void) {
+     char buf[1];
+     if (binread(buf, 1) == 0) return EOF;
+     return buf[0];
+}
+
+/* read_string -- input a null-terminated string, allocate space dynamically */
+static char *read_string() {
+     int n = 0;
+     int c;
+     char *p;
+     char buf[256];
+     
+     do {
+          c = bingetc();
+          if (c == EOF) panic("*unexpected EOF");
+          buf[n++] = c;
+     } while (c != '\0');
+
+     p = (char *) scratch_alloc(n);
+     strcpy(p, buf);
+     return p;
+}
+
+/* get_int -- get a 4-byte value in portable byte order */
+static int get_int(uchar *p) {
+     return (p[3]<<24) + (p[2]<<16) + (p[1]<<8) + p[0];
+}
+
+
+/* read_int -- input a 4-byte value in portable byte order */
+static int read_int() {
+     uchar buf[4];
+     binread(buf, 4);
+     return get_int(buf);
+}
+
+/* Here is the still centre of the whirling vortex that is byte-order
+   independence.  The compiler output, Kieko assembly language, is
+   plain text.  The assembler/linker translates this into a byte-order
+   independent file of object code.  
+
+   The bytecode in this file contains one and two byte embedded
+   constants that are in little-endian order, and the bytecode
+   interpreter puts the bytes together where necessary, respecting the
+   little-endian order in the code even on a big-endian machine.  (It
+   has to address bytecode one byte a time anyway, because of
+   alignment restrictions.)
+
+   The data segment in the object code consists of 4-byte words, and
+   these are relocated when the program is loaded.  Some of these
+   words contain character data for string constants, and they require
+   no relocation.  Some words contain integer or floating-point
+   constants, and they are relocated by swapping the byte order if
+   necessary.  Finally, some words contain addresses in the data or
+   code segment, and they are relocated by swapping the byte order as
+   needed, and adding the base address of the segment in question.
+   Thus in the running program, both the memory and the evaluation
+   stack contain only values in native byte order -- and all pointers
+   are represented as absolute addresses, enabling the program to live
+   in harmony with a conservative garbage collector.
+
+   One final twist: double-precision values are always stored as two
+   words, with each word in native byte order, but with the less
+   significant word first, even on a big-endian machine.  This is ok,
+   because these values are always loaded and stored one word at a
+   time, and assembled into native order immediately before doing
+   arithmetic. */
+
+#define REL_BLOCK 1024
+
+/* relocate -- read relocation data */
+static void relocate(int size) {
+     unsigned reloc[REL_BLOCK];
+     int n;
+
+     for (int base = 0; base < size; base += n) {
+          n = min(size - base, REL_BLOCK * CODES_PER_WORD * WORD_SIZE);
+          int nwords = (n/WORD_SIZE+CODES_PER_WORD-1)/CODES_PER_WORD;
+          binread(reloc, nwords * sizeof(unsigned));
+
+          for (int i = 0; i < n; i += WORD_SIZE) {
+               int rbits = reloc_bits(reloc, i/WORD_SIZE);
+
+#ifdef DEBUG
+               if (dflag >= 2)
+                    printf("Reloc %d %d\n", base+i, rbits);
+#endif
+
+               int m = get_int(&dmem[base+i]);
+               value *p = (value *) &dmem[base+i];
+
+               switch (rbits) {
+               case R_WORD:
+                    (*p).i = m;
+                    break;
+               case R_DATA:
+                    (*p).a = address(dmem + m);
+                    break;
+               case R_CODE:
+                    (*p).a = address(imem + m);
+                    break;
+               case R_SUBR:
+                    switch (m) {
+                    case INTERP: (*p).a = interpreter; break;
+                    case DLTRAP: (*p).a = dyntrap; break;
+                    default:
+                         panic("bad subr code");
+                    }
+                    break;
+               }
+          }
+     }
+}
+               
+/* read_symbols -- read symbol table */
+static void read_symbols(int dseg) {
+     uchar *addr;
+     int chksum, nlines;
+     int nm = 0, np = 0;
+#ifdef DEBUG
+     const char *kname;
+#define debug_kind(n) kname = n
+#else
+#define debug_kind(n)
+#endif
+          
+     modtab = (module *) scratch_alloc(nmods * sizeof(module));
+     proctab = (proc *) scratch_alloc(nprocs * sizeof(proc));
+
+     for (int i = 0; i < nsyms; i++) {
+          int kind = read_int();
+          char *name = read_string(); 
+
+          switch (kind) {
+          case X_MODULE:
+               debug_kind("Module");
+               addr = dmem + read_int(); 
+               chksum = read_int();
+               nlines = read_int();
+               modtab[nm++] = make_module(name, addr, chksum, nlines);
+               break;
+
+          case X_PROC:
+               debug_kind("Proc");
+               addr = dmem + read_int(); 
+               proctab[np++] = make_proc(name, addr);
+               break;
+                    
+          case X_DATA:
+               debug_kind("Data");
+               addr = dmem + read_int(); 
+               make_symbol("data", name, addr);
+               break;
+
+          case X_LINE:
+               debug_kind("Line");
+               addr = imem + read_int();
+               make_symbol("line", name, addr);
+               break;
+
+          default:
+               debug_kind("Unknown"); 
+               addr = NULL;
+               panic("*bad symbol %s", name);
+          }
+
+#ifdef DEBUG
+          if (dflag >= 1) printf("%s %s = %p\n", kname, name, addr);
+#endif
+     }
+
+     if (nm != nmods || np != nprocs)
+          panic("*symbol counts don't match (mods %d/%d, procs %d/%d)\n",
+                nm, nmods, np, nprocs);
+
+     /* Calculate module lengths */
+     addr = dmem + dseg;
+     for (int i = nmods-1; i >= 0; i--) {
+          modtab[i]->m_length = addr - modtab[i]->m_addr;
+          addr = modtab[i]->m_addr;
+     }
+}
+
+/* load_file -- load a file of object code */
+void load_file(FILE *bfp) {
+     /* Get trailer */
+     trailer t;
+     fseek(bfp, - (long) sizeof(trailer), SEEK_END);
+     int nread = fread(&t, 1, sizeof(trailer), bfp);
+     if (nread != sizeof(trailer)) panic("couldn't read trailer");
+
+     /* Check magic numbers */
+     if (nread < sizeof(trailer))
+          panic("couldn't read trailer");
+     if (strncmp((char *) t.magic, MAGIC, 4) != 0)
+          panic("bad magic number\n%s",
+                "[The program you are running is not a valid"
+                " Oberon bytecode file]");
+     if (get_int(t.sig) != SIG)
+          panic("bad signature %#0.8x\n%s\n%s", get_int(t.sig),
+                "[Although this appears to be an Oberon bytecode file,",
+                "  it needs a different version of the runtime system]");
+
+     /* Decode the other data */
+     int seglen[NSEGS];
+     for (int i = 0; i < NSEGS; i++)
+          seglen[i] = get_int(t.segment[i]);
+
+     code_size = seglen[S_CODE];
+     stack_size = seglen[S_STACK];
+
+     nmods = get_int(t.nmods); nprocs = get_int(t.nprocs); 
+     nsyms = get_int(t.nsyms);
+     int start = get_int(t.start);
+
+#ifdef DEBUG
+     if (dflag >= 1) {
+          printf("csize = %d, dsize = %d, bss = %d, stk = %d\n", 
+                 seglen[S_CODE], seglen[S_DATA], 
+                 seglen[S_BSS], seglen[S_STACK]);
+          printf("nmods = %d, nprocs = %d, nsyms = %d\n",
+                 nmods, nprocs, nsyms);
+     }
+#endif
+
+     fseek(bfp, start, SEEK_END);
+     binfp = bfp;
+
+     /* Load the code */
+     imem = (uchar *) scratch_alloc(seglen[S_CODE]);
+     binread(imem, seglen[S_CODE]);
+
+     /* Load and relocate the data */
+     dmem = (uchar *) scratch_alloc(seglen[S_DATA]+seglen[S_BSS]);
+     binread(dmem, seglen[S_DATA]);
+     relocate(seglen[S_DATA]);
+     memset(dmem+seglen[S_DATA], 0, seglen[S_BSS]);
+
+     /* Allocate stack */
+     stack = (uchar *) scratch_alloc(stack_size);
+
+     /* Save the entry point, pointer map and library path */
+     entry = (value *) &dmem[get_int(t.entry)];
+     gcmap = (value *) &dmem[get_int(t.gcmap)];
+     if (get_int(t.libdir) != 0)
+          libpath = (char *) &dmem[get_int(t.libdir)];
+
+     /* Read the symbols */
+     if (nsyms > 0) read_symbols(seglen[S_DATA]);
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/obcommon.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,119 @@
+/*
+ * obcommon.h
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+#ifndef EXTERN
+#define EXTERN extern
+#endif
+
+typedef unsigned char uchar;
+
+typedef int mybool;
+#define TRUE 1
+#define FALSE 0
+
+#ifndef min
+#define min(x, y) ((x) <= (y) ? (x) : (y))
+#endif
+
+#ifndef max
+#define max(x, y) ((x) <= (y) ? (y) : (x))
+#endif
+
+#define align(x, k) (((x)+((k)-1)) & ~((k)-1))
+
+#ifdef WORDS_BIGENDIAN
+#define align_byte(x) (((unsigned) (x))>>24)
+#define align_short(x) ((x)>>16)
+#else
+#define align_byte(x) (x)
+#define align_short(x) (x)
+#endif
+
+#include <stdint.h>
+
+typedef int64_t longint;
+
+typedef union {
+#ifdef WORDS_BIGENDIAN
+     struct { int hi, lo; } n;
+#else
+     struct { int lo, hi; } n;
+#endif
+     double d;
+     longint q;
+} dblbuf;
+
+/* Stack frame layout */
+#define BP 0                    /* Saved base pointer */
+#define PC 1                    /* Saved program counter */
+#define CP 2                    /* Saved context pointer */
+#define SL -1                   /* Static link */
+#define HEAD 3
+#define FRAME_SHIFT 16          /* Shift for pointer map of stack frame */
+
+/* Constant pool layout */
+#define CP_PRIM 0               /* Primitive address (64 bits) */
+#define CP_CODE 1               /* Bytecode address */
+#define CP_SIZE 2               /* Size of bytecode */
+#define CP_FRAME 3              /* Frame size */
+#define CP_STACK 4              /* Stack size */
+#define CP_MAP 5                /* Frame map */
+#define CP_STKMAP 6             /* Stack map table */
+#define CP_CONST 7              /* First constant */
+
+/* Descriptor layout */
+#define DESC_MAP 0              /* Pointer map */
+#define DESC_DEPTH 1            /* Inheritance depth of record */
+#define DESC_ANCES 2            /* Ancestor list of record */
+#define DESC_BOUND 1            /* First bound for flex array */
+
+/* Tokens used in pointer maps: all must be congruent to 2 modulo 4 */
+#define GC_BASE 2
+#define GC_REPEAT 6
+#define GC_END 10
+#define GC_MAP 14
+#define GC_FLEX 18
+#define GC_BLOCK 22
+#define GC_MARK 26
+#define GC_POINTER 30
+
+/* Error codes */
+#define E_CAST 1
+#define E_ASSIGN 2
+#define E_CASE 3
+#define E_WITH 4
+#define E_ASSERT 5
+#define E_RETURN 6
+#define E_BOUND 7
+#define E_NULL 8
+#define E_DIV 9
+#define E_FDIV 10
+#define E_STACK 11
+#define E_GLOB 12
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/oblink.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,372 @@
+/*
+ * oblink.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+#define EXTERN
+#include "oblink.h"
+#include "keiko.h"
+
+const char *version = 
+"Oxford Oberon-2 linker version " PACKAGE_VERSION " [build " REVID "]";
+const char *copyright = "Copyright (C) 1999--2012 J. M. Spivey";
+
+/* The module table has one entry for each module that appears in the
+   input files.  There's another table kept by the linker itself that
+   has one entry for each module actually selected for linking. */
+
+struct _module {
+     char *m_file;              /* Name of the file */
+     char *m_name;              /* Name of the module */
+     mybool m_lib, m_needed;    /* Whether a library module, whether needed */
+     int m_dep;                 /* Index of first prerequisite */
+     int m_check;               /* Checksum */
+};
+
+static growdecl(module);
+#define module growbuf(module, struct _module)
+#define nmodules growsize(module)
+
+/* The imports of module m are dep[module[m].m_dep .. module[m+1].m_dep) */
+
+static growdecl(dep);
+#define dep growbuf(dep, int)
+#define ndeps growsize(dep)
+
+#ifdef HAVE_GETOPT_LONG_ONLY
+static int nfiles;
+static char **file;
+#else
+static growdecl(file);
+#define file growbuf(file, char *)
+#define nfiles growsize(file)
+#endif
+
+#define MAXLINE 1024
+
+static char line[MAXLINE];
+static int nwords;
+static char *words[MAXWORDS];
+
+static mybool stdlib = TRUE;
+static char *lscript = (char *) "lscript";
+static char *interp = NULL;
+static char *outname = (char *) "a.out";
+static char *libdir = NULL;
+static char *rtlibdir = NULL;
+
+static int find_module(char *name) {
+     for (int i = 0; i < nmodules; i++)
+          if (strcmp(name, module[i].m_name) == 0)
+               return i;
+
+     return -1;
+}
+
+/* scan -- scan a file for MODULE and IMPORT directives */
+static void scan(char *name, mybool islib)  {
+     FILE *fp;
+     int m = -1, m2, chksum;
+
+     err_file = must_strdup(name);
+     fp = fopen(name, "r");
+     if (fp == NULL) {
+          perror(name);
+          exit(2);
+     }
+
+     while (fgets(line, MAXLINE, fp) != NULL) {
+          nwords = split_line(line, words);
+          if (nwords == 0) continue;
+
+          if (strcmp(words[0], "MODULE") == 0) {
+               char *mname = words[1];
+               m = find_module(mname);
+               if (m >= 0) {
+                    if (module[m].m_lib)
+                         error("%s has the same name as a library module", 
+                               words[1]);
+                    else 
+                         error("%s is loaded more than once", words[1]);
+               }
+               
+               buf_grow(module);
+               m = nmodules;
+               module[m].m_file = name;
+               module[m].m_name = must_strdup(mname);
+               module[m].m_lib = islib;
+               module[m].m_needed = FALSE;
+               module[m].m_dep = ndeps;
+               module[m].m_check = strtoul(words[2], NULL, 0);
+               nmodules++;
+          } else if (strcmp(words[0], "IMPORT") == 0) {
+               if (m < 0)
+                    error("IMPORT appears before MODULE in %s", name);
+
+               m2 = find_module(words[1]);
+               chksum = strtoul(words[2], NULL, 0);
+               buf_grow(dep);
+               if (m2 < 0) 
+                    error("%s imports %s -- please load it first",
+                          module[m].m_name, words[1]);
+               else {
+                    dep[ndeps++] = m2;
+                    if (module[m2].m_check != chksum)
+                         error("checksum of module %s does not match value"
+                               " expected by module %s", 
+                               words[1], module[m].m_name);
+               }
+          } else if (strcmp(words[0], "ENDHDR") == 0) {
+               break;
+          } else {
+               panic("*bad directive %s in file header", words[0]);
+          }
+     }
+
+     fclose(fp);
+}                              
+
+static void scan_files(void) {
+     if (stdlib) {
+          char buf[128];
+          sprintf(buf, "%s%s%s", libdir, DIRSEP, lscript);
+          FILE *fp = fopen(buf, "r");
+          if (fp == NULL) {
+               perror(buf);
+               exit(2);
+          }
+
+          while (fgets(line, MAXLINE, fp) != NULL) {
+               line[strlen(line)-1] = '\0';
+               sprintf(buf, "%s%s%s", libdir, DIRSEP, line);
+               scan(must_strdup(buf), TRUE);
+          }
+
+          fclose(fp);
+     }
+
+     for (int i = 0; i < nfiles; i++)
+          scan(file[i], FALSE);
+}
+
+/* load_needed -- load files containing needed modules */
+static void load_needed() {
+     for (int i = 0; i < nmodules; i++) {
+          if (!module[i].m_needed) continue;
+
+          char *name = module[i].m_file;
+          err_file = name;
+          FILE *fp = fopen(name, "r");
+          if (fp == NULL) {
+               perror(name);
+               exit(2);
+          }
+
+          while (fgets(line, MAXLINE, fp) != NULL) {
+               nwords = split_line(line, words);
+               if (nwords == 0) continue;
+               put_inst(words[0], &words[1], nwords-1);
+          }
+
+          fclose(fp);
+     }
+}
+
+/* trace_imports -- compute needed modules */
+static void trace_imports(void) {
+     for (int i = nmodules-1; i >= 0; i--) {
+          if (!module[i].m_lib || strcmp(module[i].m_name, "_Builtin") == 0) 
+               module[i].m_needed = TRUE;
+
+          if (module[i].m_needed)
+               for (int j = module[i].m_dep; j < module[i+1].m_dep; j++)
+                    module[dep[j]].m_needed = TRUE;
+     }
+
+#ifdef DEBUG
+     if (dflag) {
+          fprintf(stderr, "Needed:");
+          for (int i = 0; i < nmodules; i++)
+               if (module[i].m_needed)
+                    fprintf(stderr, " %s", module[i].m_name);
+          fprintf(stderr, "\n");
+     }
+#endif
+}
+
+/* gen_main -- generate the main program */
+static void gen_main(void) {
+     char buf[128];
+
+     if (known("MAIN")) return;
+
+     err_file = (char *) "main program";
+
+     /* For completeness, generate a header listing all loaded modules. */
+     gen_inst("MODULE %%Main 0 0");
+     for (int i = 0; i < nmodules; i++) {
+          if (strcmp(module[i].m_name, "_Builtin") == 0 
+              || !module[i].m_needed) continue;
+          gen_inst("IMPORT %s %#x", module[i].m_name, module[i].m_check);
+     }
+     gen_inst("ENDHDR");
+
+     gen_inst("PROC MAIN 0 4 0");
+     /* Code to call each module body */
+     for (int i = 0; i < nmodules; i++) {
+          if (!module[i].m_needed) continue;
+          sprintf(buf, "%s.%%main", module[i].m_name);
+          if (known(buf)) {
+               gen_inst("GLOBAL %s", buf);
+               gen_inst("CALL 0");
+          }
+     }
+     gen_inst("RETURN");
+     gen_inst("END");
+
+     /* Make global pointer map */
+     gen_inst("DEFINE GCMAP");
+     for (int i = 0; i < nmodules; i++) {
+          if (!module[i].m_needed) continue;
+          sprintf(buf, "%s.%%gcmap", module[i].m_name);
+          if (known(buf)) {
+               gen_inst("WORD GC_MAP");
+               gen_inst("WORD %s", buf);
+          }
+     }
+     gen_inst("WORD GC_END");
+}
+
+#include <getopt.h>
+
+#define SCRIPT 1
+
+static struct option longopts[] = {
+     { "script", required_argument, NULL, SCRIPT },
+     { "nostdlib", no_argument, &stdlib, FALSE },
+     { "pl", no_argument, &linecount, TRUE },
+     { NULL, 0, NULL, 0 }
+};
+
+/* get_options -- analyse arguments */
+static void get_options(int argc, char **argv) {
+     for (;;) {
+          int c = getopt_long_only(argc, argv, "dvsgCi:L:R:o:k:", 
+                                   longopts, NULL);
+
+          if (c == -1) break;
+
+          switch (c) {
+          case 'd':
+               dflag++; break;
+          case 'v':
+               printf("%s\n", version);
+               exit(0);
+               break;
+          case 's':
+               sflag = TRUE; break;
+          case 'g':
+               gflag = TRUE; break;
+          case 'C':
+               custom = TRUE; break;
+          case 'i':
+               interp = optarg; break;
+          case 'L':
+               libdir = optarg; break;
+          case 'R':
+               rtlibdir = optarg; break;
+          case 'o':
+               outname = optarg; break;
+          case 'k':
+               stack_size = atoi(optarg);
+               if (stack_size < MIN_STACK) stack_size = MIN_STACK;
+               break;
+          case 0:
+               /* Long option with flag */
+               break;
+          case SCRIPT:
+               /* -script */
+               lscript = optarg; break;
+          case '?':
+               /* Error has been reported by getopt */
+               exit(2);
+               break;
+          default:
+               panic("*bad option");
+          }
+     }
+
+     nfiles = argc - optind;
+     file = &argv[optind];
+}
+
+int main(int argc, char **argv) {
+     progname = argv[0];
+
+     buf_init(module, INIT_MODS, 1, struct _module, "modules");
+     buf_init(dep, INIT_MODS, 1, int, "dependencies");
+
+     stack_size = STACK_SIZE;
+
+     get_options(argc, argv);
+     if (nfiles == 0) panic("no input files");
+     if (stdlib && libdir == NULL) panic("no libdir specified");
+     if (rtlibdir == NULL) rtlibdir = libdir;
+
+#define bind(x) def_global(find_symbol(#x), ABS, x, X_SYM)
+
+     bind(GC_BASE); bind(GC_REPEAT); bind(GC_BLOCK);
+     bind(GC_MAP); bind(GC_FLEX); bind(GC_END); bind(GC_POINTER);
+     bind(E_CAST); bind(E_ASSIGN); bind(E_CASE);
+     bind(E_WITH); bind(E_ASSERT); bind(E_RETURN);
+     bind(E_BOUND); bind(E_NULL); bind(E_DIV);
+     bind(E_FDIV); bind(E_STACK); bind(E_GLOB);
+
+     /* First pass -- check for dependencies */
+     scan_files();
+
+     /* Compute needed modules */
+     buf_grow(module);
+     module[nmodules].m_dep = ndeps;
+     trace_imports();
+
+     if (status != 0) return status;
+
+     /* Second pass -- link the modules that are needed */
+     init_linker(outname, interp);
+     load_needed();
+     gen_main();
+     if (rtlibdir != NULL)
+          save_string("LIBDIR", rtlibdir);
+     end_linking();
+
+     if (custom)
+          dump_prims();
+
+     return status;
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/oblink.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,135 @@
+/*
+ * oblink.h
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#include <assert.h>
+#include "obcommon.h"
+#include "exec.h"
+
+#ifdef DEBUG
+/* Small tables to help test auto-growth */
+#define INIT_PMEM 8             /* Init space for procedures */
+#define INIT_XMEM 128           /* Same for data buffer */
+#define INIT_LMEM 16            /* Same for local labels */
+#define INIT_SMEM 16            /* Same for symbol table */
+#define INIT_MODS 10            /* Init space for modules */
+#else
+#define INIT_PMEM 256           /* Init space for procedures */
+#define INIT_XMEM 2048          /* Same for data buffer */
+#define INIT_LMEM 1024          /* Same for local labels */
+#define INIT_SMEM 1024          /* Same for symbol table */
+#define INIT_MODS 100           /* Init space for modules */
+#endif
+
+#define STACK_SIZE (1024 * 1024 - 32)   
+                                /* Default stack size (bytes) */
+#define MIN_STACK 4096          /* Min stack size (bytes) */
+
+typedef enum { ABS, DATA, BSS, CODE, UNDEFINED } segment;
+
+typedef struct _phrase *phrase;
+
+#ifdef __cplusplus
+#define template xyzzy
+#endif
+
+typedef struct _template *template;
+
+#define MAXMAC 6
+
+struct _template {              /* An encoding of an instruction */
+     const char *t_name;        /* The instruction */
+     const char *t_pattern;     /* Argument formats */
+     int t_lo, t_hi, t_step;    /* Pattern of values for 'N' format */
+     int t_size;                /* Total length of instruction */
+     int t_oplen;               /* Length of opcode */
+     uchar t_op;                /* Opcode */
+     const char *t_macro[MAXMAC]; /* Macro expansion */
+};
+
+#define put1(buf, x) put_int(1, buf, x)
+#define put2(buf, x) put_int(2, buf, x)
+#define put4(buf, x) put_int(4, buf, x)
+
+EXTERN int dflag;
+EXTERN int zflag;               /* Whether to compress the bytecode */
+EXTERN mybool sflag;            /* Whether to suppress symbol table */
+EXTERN mybool gflag;            /* Whether to output extra debugging info */
+EXTERN mybool custom;           /* Whether to output a primitive table */
+EXTERN mybool linecount;
+EXTERN int stack_size;
+
+/* template.c */
+extern struct _template templates[];
+extern short templ_trie[];
+extern uchar templ_check[];
+
+/* symtab.c */
+typedef struct _symbol *symbol;
+
+symbol make_symbol(const char *name);
+symbol find_symbol(const char *name);
+const char *sym_name(symbol s);
+void def_global(symbol s, segment seg, int off, int kind);
+void use_global(symbol s, uchar *base, int offset);
+int sym_value(symbol s);
+mybool known(const char *name);
+void fix_data(uchar *base, int bss);
+int write_symtab(void);
+void module_data(symbol s, unsigned checksum, int nlines);
+
+void init_labels(void);
+int make_label(symbol s);
+const char *label_name(int n);
+void def_label(symbol s, phrase val);
+phrase find_label(int n);
+
+/* linker.c */
+void init_linker(char *outname, char *interp);
+void put_inst(const char *name, char *rands[], unsigned nrands);
+void gen_inst(const char *fmt, ...);
+void save_string(const char *label, char *string);
+void open_output(char *name, char *interp);
+void end_linking(void);
+void dump_prims(void);
+
+void relocate(int loc, int bits);
+
+void put_int(int n, uchar *buf, int x);
+int get4(uchar *buf);
+void write_string(const char *s);
+void write_int(int n, int x);
+
+/* util.c */
+#include "util.h"
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/obx.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,320 @@
+/*
+ * obx.h
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+#ifndef _OBX_H
+#define _OBX_H 1
+
+#ifdef TRACE
+#define DEBUG 1
+#endif
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdarg.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h> 
+#endif
+#include "obcommon.h"
+
+#define SLIMIT 256              /* Min stack space space left (bytes) */
+
+typedef union value value;
+
+typedef void primitive(value *sp);
+
+typedef uint32_t word;
+typedef uintptr_t ptrtype;
+
+union value {
+     int i;
+     float f;
+     word a;
+};
+
+#define valptr(v) ((value *) (ptrtype) ((v).a))
+#define pointer(v) ((void *) (ptrtype) ((v).a))
+
+#define address(p) ((word) (ptrtype) (p))
+#define ptrcast(t, a) ((t *) (ptrtype) (a))
+
+typedef struct _proc *proc;
+typedef struct _module *module;
+typedef struct _arc *arc;
+
+#ifdef PROFILE
+typedef uint64_t counter;
+#endif
+
+struct _proc {
+     const char *p_name;        /* Procedure name */
+     value *p_addr;             /* Address of descriptor in data space */
+#ifdef PROFILE
+     int p_index;               /* Position in listing */
+     unsigned p_calls;          /* Call count */
+     unsigned p_rec;            /* Call count for recursion */
+     counter p_self;            /* Tick count for self */
+     counter p_child;           /* Tick count for children */
+     arc p_parents;             /* List of callers */
+     arc p_children;            /* List of procs we call */
+#endif
+};
+
+struct _module {
+     char *m_name;              /* Layout must match proc */
+     uchar *m_addr;
+     int m_length;
+#ifdef PROFILE
+     int m_nlines;
+     unsigned *m_lcount;
+#endif
+};
+
+
+/* Global variables */
+EXTERN uchar *imem, *dmem;      /* Instruction and data memory arrays */
+EXTERN uchar *stack;            /* Program stack */
+EXTERN int code_size;           /* Size of program code */
+EXTERN int stack_size;          /* Size of main stack */
+EXTERN char *libpath;           /* Path to dynamic library */
+EXTERN value *entry;            /* Program entry point */
+EXTERN value *gcmap;            /* Global pointer map */
+EXTERN word interpreter, dyntrap;
+#ifdef USEFFI
+EXTERN word dynstub;
+#endif
+
+#define interpreted(p) ((p)[CP_PRIM].a == interpreter)
+
+#ifndef M64X32
+#define primcall(p, sp)  ((primitive *) p[CP_PRIM].a)(sp)
+#else
+#define primcall(p, sp)  (*ptrcast(primitive *, p[CP_PRIM].a))(sp)
+#endif
+
+#define get1(p)  ((int) ((signed char) (p)[0]))
+#define get2(p)  ((int) ((short) (((p)[1]<<8) + (p)[0])))
+
+EXTERN int nmods, nprocs, nsyms;
+EXTERN module *modtab;
+EXTERN proc *proctab;
+
+extern struct primdef {
+     char *p_name;
+     primitive *p_prim;
+} primtab[];
+
+#ifndef M64X32
+EXTERN value _result[2];        /* Procedure result */
+EXTERN value *statlink;         /* Static link for procedure call */
+#else
+EXTERN value *_result;
+EXTERN value **_stat;
+#define statlink (*_stat)
+#endif
+
+#define ob_res _result[0]
+
+EXTERN int level;               /* Recursion level in bytecode interp. */
+#ifdef OBXDEB
+EXTERN value *prim_bp;          /* Base pointer during primitive call */
+#endif
+
+EXTERN int dflag;
+EXTERN mybool gflag;
+#ifdef PROFILE
+EXTERN mybool lflag;
+#endif
+#ifdef TRACE
+EXTERN int qflag;
+#endif
+#ifdef OBXDEB
+EXTERN char *debug_socket;
+#endif
+
+#define divop_decl(t) \
+     t t##_divop(t a, t b, int div) {           \
+          t quo = a / b, rem = a % b;           \
+          if (rem != 0 && (rem ^ b) < 0) {      \
+               rem += b; quo--;                 \
+          }                                     \
+          return (div ? quo : rem);             \
+     }
+
+
+/* profile.c */
+#ifdef PROFILE
+void prof_enter(value *p, counter ticks, int why);
+void prof_exit(value *p, counter ticks);
+void prof_init(void);
+void prof_reset(proc p);
+void profile(FILE *fp);
+
+#define PROF_CALL 1
+#define PROF_TAIL 2
+#define PROF_PRIM 3
+#endif
+
+/* interp.c */
+primitive interp, dltrap, dlstub;
+
+/* xmain.c */
+EXTERN int saved_argc;
+EXTERN char **saved_argv;
+
+int obgetc(FILE *fp);
+void xmain_exit(int status);
+void error_exit(int status);
+
+/* support.c */
+int ob_div(int a, int b);
+int ob_mod(int a, int b);
+
+void int_div(value *sp);
+void int_mod(value *sp);
+
+void long_add(value *sp);
+void long_sub(value *sp);
+void long_mul(value *sp);
+void long_div(value *sp);
+void long_mod(value *sp);
+void long_neg(value *sp);
+void long_cmp(value *sp);
+void long_flo(value *sp);
+void long_ext(value *sp);
+void long_zcheck(value *sp);
+
+word wrap_prim(primitive *prim);
+
+/* dynlink.c */
+void load_lib(char *fname);
+void dltrap(value *sp);
+
+/* load_file -- load a file of object code */
+void load_file(FILE *bfp);
+
+module make_module(char *name, uchar *addr, int chsum, int nlines);
+proc make_proc(char *name, uchar *addr);
+void make_symbol(const char *kind, char *name, uchar *addr);
+
+void panic(const char *, ...);
+void obcopy(char *dst, int dlen, const char *src, int slen, value *bp);
+
+void error_stop(const char *msg, int line, value *bp, uchar *pc);
+void runtime_error(int num, int line, value *bp, uchar *pc);
+void rterror(int num, int line, value *bp);
+void stkoflo(value *bp);
+#define liberror(msg) error_stop(msg, 0, bp, NULL)
+
+proc find_symbol(value *p, proc *table, int nelem);
+#define find_proc(cp) find_symbol(cp, proctab, nprocs)
+#define find_module(cp) ((module) find_symbol(cp, (proc *) modtab, nmods))
+
+#ifdef TRACE
+char *fmt_inst(uchar *pc);
+void dump(void);
+const char *prim_name(value *p);
+#endif
+
+#ifdef UNALIGNED_MEM
+#define get_double(v) (* (double *) (v))
+#define put_double(v, x) (* (double *) (v) = (x))
+#define get_long(v) (* (longint *) (v))
+#define put_long(v, x) (* (longint *) (v) = (x))
+#else
+double get_double(value *v);
+void put_double(value *v, double x);
+longint get_long(value *v);
+void put_long(value *v, longint w);
+#endif
+
+double flo_conv(int);
+double flo_convq(longint);
+
+#ifdef SPECIALS
+int pack(value *code, uchar *env);
+value *getcode(int word);
+uchar *getenvt(int word);
+#endif
+
+/* gc.c */
+
+/* scratch_alloc -- allocate memory that will not be freed */
+void *scratch_alloc(unsigned bytes);
+
+/* gc_alloc -- allocate an object for the managed heap */
+void *gc_alloc(value *desc, unsigned size, value *sp);
+
+/* gc_collect -- run the garbage collector */
+void gc_collect(value *xsp);
+
+/* gc_alloc_size -- calculate allocated size of and object */
+int gc_alloc_size(void *p);
+
+/* gc_heap_size -- return size of heap */
+int gc_heap_size(void);
+
+extern mybool gcflag;
+void gc_init(void);
+void gc_debug(char *flags);
+void gc_dump(void);
+
+/* debug.c */
+#ifdef OBXDEB
+extern mybool one_shot;
+extern mybool intflag;
+
+void debug_init(void);
+void debug_message(char *fmt, ...);
+void debug_break(value *cp, value *bp, uchar *pc, char *fmt, ...);
+#endif
+
+/* jit.c */
+#ifdef JIT
+void jit_compile(value *cp);
+void jit_trap(value *cp);
+#endif
+
+#ifdef __cplusplus
+#define PRIMDEF extern "C"
+#else
+#define PRIMDEF
+#endif
+
+#ifdef NEED_FPINIT
+/* On x86, each primitive re-initialises the FP unit, so that values
+   left behind in registers by the caller do not cause stack overflow. */
+#define FPINIT asm ("fninit")
+#else
+#define FPINIT
+#endif
+
+#endif
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/primtab.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,181 @@
+/*
+ * primtab.h
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 "obx.h"
+#include <math.h>
+#include <ctype.h>
+
+/* Types for each kind of argument */
+typedef int type_C, type_I;
+typedef longint type_L;
+typedef float type_F;
+typedef double type_D;
+typedef void *type_P, *type_Q, *type_X;
+typedef void type_V;
+
+/* Size of each kind in argument words */
+#define size_C 1
+#define size_I 1
+#define size_F 1
+#define size_P 1
+#define size_L 2
+#define size_D 2
+#define size_X 2
+#define size_Q 2
+
+/* How to fetch each kind of argument */
+#define arg_I(j)  bp[HEAD+j].i
+#define arg_C(j)  align_byte(bp[HEAD+j].i)
+#define arg_L(j)  get_long(&bp[HEAD+j])
+#define arg_F(j)  bp[HEAD+j].f
+#define arg_D(j)  get_double(&bp[HEAD+j])
+#define arg_P(j)  pointer(bp[HEAD+j])
+#define arg_X(j)  pointer(bp[HEAD+j])
+#define arg_Q(j)  ptrcast(void, get_long(&bp[HEAD+j]))
+
+/* How to return each kind of result via ob_res */
+#define res_I(v)  ob_res.i = v
+#define res_C(v)  ob_res.i = v
+#define res_F(v)  ob_res.f = v
+#define res_P(v)  ob_res.a = address(v)
+#define res_L(v)  put_long(&ob_res, v)
+#define res_D(v)  put_double(&ob_res, v)
+#define res_Q(v)  put_long(&ob_res, (ptrtype) v)
+#define res_V(v)  v
+
+/* Three kinds of primitive: 
+   DIRECT   -- defined by a function "void prim(value *bp)"
+   WRAPPER  -- defined by an foreign function prim that declared in one of 
+               the included header files.  We generate a wrapper P_prim.
+   INDIRECT -- defined by an internal function in some library module, with
+               a natural type.  We generate a wrapper that includes a
+               declaration of the function. 
+
+   Call WRAPPER(name, res, a1, a2, ..., an) where res and a1, ..., an are
+   type letters for the result and arguments. */
+
+#define DIRECT(name)  void name(value *bp);
+#define WRAPPER(...)  WRAP(_WRAP, 0, __VA_ARGS__)
+#define INDIRECT(...) WRAP(_INDIR, 0, __VA_ARGS__)
+
+/* WRAP(mac, base, name, res, a1, ..., an) is
+
+   mac(name, res, 
+       (type_a1, ..., type_an), 
+       (arg_a1(base), arg_a2(base+s1), arg_a3(base+s1+s2), ..., 
+           arg_an(base+s1+s2+...s(n-1))))
+   
+   where si = size_ai. */
+
+#define WRAP(mac, base, ...)                          \
+     SELECT(__VA_ARGS__, WRAP6, WRAP5, WRAP4, WRAP3, \
+                 WRAP2, WRAP1, WRAP0)(mac, base, __VA_ARGS__)
+
+#define SELECT(n, r, a1, a2, a3, a4, a5, a6, t, ...) t
+
+#define WRAP0(mac, base, name, res)              \
+     mac(name, res, (void), ())
+#define WRAP1(mac, base, name, res, a1)          \
+     mac(name, res, (type_##a1), (arg_##a1(base)))
+#define WRAP2(mac, base, name, res, a1, a2)                      \
+     mac(name, res, (type_##a1, type_##a2), (args2(base, a1, a2)))
+#define WRAP3(mac, base, name, res, a1, a2, a3)  \
+     mac(name, res, \
+         (type_##a1, type_##a2, type_##a3), \
+         (args3(base, a1, a2, a3)))
+#define WRAP4(mac, base, name, res, a1, a2, a3, a4)      \
+     mac(name, res, \
+         (type_##a1, type_##a2, type_##a3, type_##a4), \
+         (args4(base, a1, a2, a3, a4)))
+#define WRAP5(mac, base, name, res, a1, a2, a3, a4, a5)  \
+     mac(name, res, \
+         (type_##a1, type_##a2, type_##a3, type_##a4, type_##a5), \
+         (args5(base, a1, a2, a3, a4, a5)))
+#define WRAP6(mac, base, name, res, a1, a2, a3, a4, a5, a6)      \
+     mac(name, res, \
+         (type_##a1, type_##a2, type_##a3, type_##a4, type_##a5, type_##a6), \
+         (args6(base, a1, a2, a3, a4, a5, a6)))
+
+#define args2(j, a1, a2) \
+     arg_##a1(j), arg_##a2(j+size_##a1)
+#define args3(j, a1, a2, a3) \
+     arg_##a1(j), args2(j+size_##a1, a2, a3)
+#define args4(j, a1, a2, a3, a4) \
+     arg_##a1(j), args3(j+size_##a1, a2, a3, a4)
+#define args5(j, a1, a2, a3, a4, a5) \
+     arg_##a1(j), args4(j+size_##a1, a2, a3, a4, a5)
+#define args6(j, a1, a2, a3, a4, a5, a6) \
+     arg_##a1(j), args5(j+size_##a1, a2, a3, a4, a5, a6)
+
+/* How to generate a wrapper function with (_INDIR) or without (_WRAP)
+   a declaration of the function being wrapped. */
+#define _WRAP(name, res, atypes, args) \
+     __WRAP(, name, res, args)
+#define _INDIR(name, res, atypes, args) \
+     __WRAP(type_##res name atypes;, name, res, args)
+#define __WRAP(decl, name, res, args) \
+     void P_##name(value *bp) { decl FPINIT; res_##res(name args); }
+
+#define WRAPPERS(prims) prims(DIRECT, INDIRECT, WRAPPER)
+
+/* How to generate entries in the primitive table */
+#define DPRIM(name, ...)  { #name, name },
+#define IPRIM(name, ...)  DPRIM(P_##name)
+
+#define TABLE(prims)              \
+     struct primdef primtab[] = { \
+          prims(DPRIM, IPRIM, IPRIM) \
+          { NULL, NULL }          \
+     };
+
+/* If dynamic linking is enabled, we don't need a static table of
+   primitives; if not, then we make a table and dltrap(dynlink.c)
+   will search it. Note that we can have statically generated wrappers
+   for speed even if FFI is available. */
+
+#ifdef DYNLINK
+#define PRIMTAB(prims) WRAPPERS(prims)
+#else
+#define PRIMTAB(prims) WRAPPERS(prims) TABLE(prims)
+#endif
+
+/* Variation for the compilers course with offset to compensate for
+   dummy static link */
+
+#define PWRAPPER(...)  WRAP(_WRAP, 1, __VA_ARGS__)
+#define PINDIRECT(...) WRAP(_INDIR, 1, __VA_ARGS__)
+#define PWRAPPERS(prims) prims(DIRECT, PINDIRECT, PWRAPPER)
+
+#ifdef DYNLINK
+#define PPRIMTAB(prims) PWRAPPERS(prims)
+#else
+#define PPRIMTAB(prims) PWRAPPERS(prims) TABLE(prims)
+#endif
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/support.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,254 @@
+/*
+ * support.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 "obx.h"
+
+/* Assorted runtime support routines */
+
+void panic(const char *msg, ...) {
+     va_list va;
+
+     mybool bug = FALSE;
+
+     if (*msg == '*') {
+          bug = TRUE; msg++;
+     }
+
+     fflush(stdout);
+     fprintf(stderr, "Fatal error: ");
+     va_start(va, msg);
+     vfprintf(stderr, msg, va);
+     va_end(va);
+     fprintf(stderr, "\n");
+     if (bug)
+          fprintf(stderr, "Please report bugs to %s or %s\n",
+                  PACKAGE_TRACKER, PACKAGE_BUGREPORT);
+     fflush(stderr);
+     error_exit(3);
+}
+
+
+/* Division operators for jit code */
+
+static inline divop_decl(int)
+static inline divop_decl(longint)
+
+void int_div(value *sp) {
+     sp[1].i = int_divop(sp[1].i, sp[0].i, 1);
+}
+
+void int_mod(value *sp) {
+     sp[1].i = int_divop(sp[1].i, sp[0].i, 0);
+}
+
+void long_div(value *sp) {
+     put_long(sp+2, longint_divop(get_long(sp+2), get_long(sp), 1));
+}
+
+void long_mod(value *sp) {
+     put_long(sp+2, longint_divop(get_long(sp+2), get_long(sp), 0));
+}
+
+void long_flo(value *sp) {
+     put_double(sp, get_long(sp));
+}
+
+void long_zcheck(value *sp) {
+     if (get_long(sp+2) == 0)
+          rterror(E_DIV, sp[0].i, ptrcast(value, sp[1].a));
+}
+
+#ifndef M64X32
+void long_add(value *sp) {
+     put_long(sp+2, get_long(sp+2) + get_long(sp));
+}
+
+void long_sub(value *sp) {
+     put_long(sp+2, get_long(sp+2) - get_long(sp));
+}
+
+void long_mul(value *sp) {
+     put_long(sp+2, get_long(sp+2) * get_long(sp));
+}
+
+void long_neg(value *sp) {
+     put_long(sp, -get_long(sp));
+}
+
+void long_cmp(value *sp) {
+     longint a = get_long(sp+2), b = get_long(sp);
+     sp[3].i = (a < b ? -1 : a > b ? 1 : 0);
+}
+
+void long_ext(value *sp) {
+     put_long(sp-1, (longint) sp[0].i);
+}
+#endif
+
+
+/* Conversions between int and floating point */
+
+#ifndef GCOV
+/* These are not done inline in interp() because that upsets the
+   gcc optimiser on i386, adding overhead to every instruction. */
+double flo_conv(int x) { 
+     return (double) x; 
+}
+
+double flo_convq(longint x) {
+     return (double) x;
+}
+#endif
+
+/* obcopy -- like strncpy, but guarantees termination with zero */
+void obcopy(char *dst, int dlen, const char *src, int slen, value *bp) {
+     if (slen == 0 || dlen < slen) {
+          strncpy(dst, src, dlen);
+          if (dst[dlen-1] != '\0')
+               liberror("string copy overflows destination");
+     } else {
+          strncpy(dst, src, slen);
+          if (dst[slen-1] != '\0')
+               liberror("source was not null-terminated");
+          memset(&dst[slen], '\0', dlen-slen);
+     }
+}
+
+#ifndef UNALIGNED_MEM
+double get_double(value *v) {
+     dblbuf dd;
+     dd.n.lo = v[0].i;
+     dd.n.hi = v[1].i;
+     return dd.d;
+}
+
+void put_double(value *v, double x) {
+     dblbuf dd;
+     dd.d = x;
+     v[0].i = dd.n.lo;
+     v[1].i = dd.n.hi;
+}
+
+longint get_long(value *v) {
+     dblbuf dd;
+     dd.n.lo = v[0].i;
+     dd.n.hi = v[1].i;
+     return dd.q;
+}
+
+void put_long(value *v, longint x) {
+     dblbuf dd;
+     dd.q = x;
+     v[0].i = dd.n.lo;
+     v[1].i = dd.n.hi;
+}
+#endif
+
+/* find_symbol -- find a procedure from its CP. Works for modules too. */
+proc find_symbol(value *p, proc *table, int nelem) {
+     int a = 0, b = nelem;
+
+     if (p == NULL) return NULL;
+     if (nelem == 0 || p < table[0]->p_addr) return NULL;
+
+     /* Binary search */
+     /* Inv: 0 <= a < b <= nelem, table[a] <= x < table[b], 
+        where table[nelem] = infinity */
+     while (a+1 != b) {
+          int m = (a+b)/2;
+          if (table[m]->p_addr <= p)
+               a = m;
+          else
+               b = m;
+     }
+
+     return table[a];
+}
+
+#ifdef WINDOWS
+#ifdef OBXDEB
+#define OBGETC 1
+#endif
+#endif
+
+/* obgetc -- version of getc that compensates for Windows quirks */
+int obgetc(FILE *fp) {
+#ifdef OBGETC
+     /* Even if Ctrl-C is trapped, it causes a getc() call on the console
+        to return EOF. */
+     for (;;) {
+          int c = getc(fp);
+          if (c == EOF && intflag && prim_bp != NULL) {
+               value *cp = valptr(prim_bp[CP]);
+               debug_break(cp , prim_bp, NULL, "interrupt");
+               continue;
+          }
+          return c;
+     }
+#else
+     return getc(fp);
+#endif
+}
+
+#ifdef SPECIALS
+/* Specials for the compiler course */
+
+value *clotab[256];
+int nclo = 0;
+
+int pack(value *code, uchar *env) {
+     unsigned tag, val;
+
+     for (tag = 0; tag < nclo; tag++)
+          if (clotab[tag] == code) break;
+
+     if (tag == nclo) {
+          if (nclo == 256) panic("Out of closure tags");
+          clotab[nclo++] = code;
+     }
+
+     if (env != NULL && (env <= stack || env > stack + stack_size)) 
+          panic("Bad luck in pack");
+
+     val = (env == NULL ? 0 : env - stack);
+
+     return (tag << 24) | val;
+}
+
+value *getcode(int word) {
+     unsigned tag = ((unsigned) word) >> 24;
+     return clotab[tag];
+}
+
+uchar *getenvt(int word) {
+     unsigned val = ((unsigned) word) & 0xffffff;
+     return (val == 0 ? NULL : stack + val);
+}
+#endif
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/symtab.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,287 @@
+/*
+ * symtab.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 "oblink.h"
+
+/* This module implements two completely independent symbol tables:
+   one for global symbols, and another for labels used in branches.
+   Global symbols have symbolic names, and are used only in the data
+   segment. Labels have names that are integers. */
+
+
+/* GLOBAL SYMBOLS */
+
+struct _symbol {
+     const char *s_name;        /* Name of the symbol */
+     segment s_seg;             /* Segment, or UNDEFINED */
+     int s_kind;                /* Kind of symbol -- X_PROC, etc. */
+     int s_value;               /* Numeric value */
+     unsigned s_index;          /* Index as a local label */
+     unsigned s_check;          /* Checksum for module */
+     int s_nlines;              /* Line count for module */
+     symbol s_next;             /* Next in hash chain */
+     int s_uchain;              /* Start of use chain in data segment */
+     char *s_file;              /* Source file that uses the symbol */
+};
+
+#define HSIZE 1024
+
+static symbol stable[HSIZE];
+
+static growdecl(dict);
+#define dict growbuf(dict, symbol)
+#define ndict growsize(dict)
+
+/* make_symbol -- create a symbol, but don't put it in the hash table */
+symbol make_symbol(const char *name) {
+     symbol s = 
+          (symbol) must_alloc(sizeof(struct _symbol), "symbol table entry");
+     s->s_name = must_strdup(name);
+     s->s_seg = UNDEFINED;
+     s->s_kind = X_NONE;
+     s->s_value = -1;
+     s->s_next = NULL;
+     s->s_index = 0;
+     s->s_uchain = -1;
+     s->s_check = s->s_nlines = 0;
+     s->s_file = NULL;
+
+     buf_grow(dict);
+     dict[ndict++] = s;
+     return s;
+}
+
+static symbol lookup(const char *name, mybool create) {
+     if (dict == NULL)
+          buf_init(dict, INIT_SMEM, 1, symbol, "symbol table");
+
+     unsigned h = 0;
+     for (const char *p = name; *p != '\0'; p++) h = 5 * h + *p;
+     h %= HSIZE;
+
+     symbol s;
+     for (s = stable[h]; s != NULL; s = s->s_next)
+          if (strcmp(name, s->s_name) == 0)
+               return s;
+
+     if (create) {
+          s = make_symbol(name);
+          s->s_next = stable[h];
+          stable[h] = s;
+     }
+
+     return s;
+}
+
+/* find_symbol -- find a global symbol, or create one if necessary */
+symbol find_symbol(const char *name) {
+     return lookup(name, TRUE);
+}
+
+/* known -- test if a symbol has been entered */
+mybool known(const char *name) {
+     symbol s = lookup(name, FALSE);
+     return (s != NULL);
+}
+
+const char *sym_name(symbol s) {
+     return s->s_name;
+}
+
+/* sym_value -- compute value of global symbol */
+int sym_value(symbol s) {
+     if (s->s_file == NULL) s->s_file = err_file;
+
+     if (s->s_seg == UNDEFINED) {
+          err_file = s->s_file;
+          error("undefined symbol %s", s->s_name);
+          s->s_seg = ABS;
+     }
+
+     return s->s_value;
+}
+
+#ifdef DEBUG
+static const char *seg_name[] = { 
+     "abs", "data", "bss", "code", "undefined"
+};
+#endif
+
+/* def_global -- set value of a global symbol */
+void def_global(symbol s, segment seg, int off, int kind) {
+     if (s->s_seg != UNDEFINED)
+          error("multiply defined symbol %s", s->s_name);
+
+     s->s_seg = seg;
+     s->s_value = off;
+     s->s_kind = kind;
+
+#ifdef DEBUG
+     if (dflag)
+          fprintf(stderr, "Symbol %s = %d(%s)\n", 
+                  s->s_name, s->s_value, seg_name[s->s_seg]);
+#endif
+}
+
+/* Uses of globals are linked in chains, so the values can be patched at
+the last minute before the data segment is output.  Because the buffer for
+the data segment may grow and be relocated, we must store the links as
+offsets from the start of the buffer. */
+
+/* use_global -- add location to use chain for a global symbol */
+void use_global(symbol s, uchar *base, int offset) {
+     if (s->s_file == NULL) s->s_file = err_file;
+     *((int *) &base[offset]) = s->s_uchain;
+     s->s_uchain = offset;
+}
+
+/* fix_data -- fix up global refs in the data segment */
+void fix_data(uchar *base, int bss) {
+     /* Shift BSS symbols by offset bss */
+     for (int i = 0; i < ndict; i++) {
+          symbol s = dict[i];
+          if (s->s_seg == BSS) s->s_value += bss;
+     }
+
+     /* Fix up each symbol */
+     for (int i = 0; i < ndict; i++) {
+          symbol s = dict[i];
+          int val;
+
+          if (s->s_uchain == -1) continue;
+
+          if (dflag > 0) printf("Fixing %s\n", s->s_name);
+
+          val = sym_value(s);
+
+          /* Run along the use chain, inserting the value */
+          for (int u = s->s_uchain, v; u != -1; u = v) {
+               v = *((int *) &base[u]);
+               put4(&base[u], val);
+               relocate(u, (s->s_seg == ABS ? R_WORD : R_DATA));
+          }
+     }
+}
+
+/* module_data -- add data for module */
+void module_data(symbol s, unsigned checksum, int nlines) {
+     s->s_check = checksum;
+     s->s_nlines = nlines;
+}
+
+static int cf_syms(symbol *a, symbol *b) {
+     int z = (*a)->s_kind - (*b)->s_kind;
+     if (z == 0) z = (*a)->s_value - (*b)->s_value;
+     return z;
+}
+
+/* write_symtab -- write the symbol table */
+int write_symtab(void) {
+     int nwritten = 0;
+
+     qsort(dict, ndict, sizeof(symbol), 
+           (int (*)(const void *, const void *)) cf_syms);
+
+     for (int i = 0; i < ndict; i++) {
+          symbol s = dict[i];
+
+          if (s->s_kind == X_SYM || s->s_kind == X_NONE) continue;
+
+          write_int(4, s->s_kind);
+          write_string(s->s_name);
+          write_int(4, s->s_value);
+
+          if (s->s_kind == X_MODULE) {
+               write_int(4, s->s_check);
+               write_int(4, s->s_nlines);
+          }
+
+          nwritten++;
+     }
+
+     return nwritten;
+}
+
+
+/* LOCAL LABELS */
+
+/* The table contains local symbols for the current procedure only.
+   As the procedure is initially assembled into the linker's buffer,
+   the value of each label is defined as its location in the buffer.
+   When the procedure is complete, we replace each use of a 
+   label by the corresponding value.  The values are turned into 
+   offsets as the code is output. */ 
+
+struct _locdef {
+     symbol l_lab;
+     phrase l_val;
+};
+
+static growdecl(locdefs);
+#define locdefs growbuf(locdefs, struct _locdef)
+#define n_locs growsize(locdefs)
+
+void init_labels(void) {
+     if (locdefs == NULL)
+          buf_init(locdefs, INIT_LMEM, 1, struct _locdef, "labels");
+     n_locs = 0;
+}
+
+int make_label(symbol s) {
+     int n = s->s_index;
+
+     if (s->s_index >= n_locs || locdefs[s->s_index].l_lab != s) {
+          buf_grow(locdefs);
+          n = n_locs++;
+          locdefs[n].l_lab = s;
+          locdefs[n].l_val = NULL;
+          s->s_index = n;
+     }
+
+     return n;
+}
+
+const char *label_name(int n) {
+     return sym_name(locdefs[n].l_lab);
+}
+
+void def_label(symbol s, phrase val) {
+     int n = make_label(s);
+     if (locdefs[n].l_val != NULL)
+          error("multiply defined label %s", s->s_name);
+     locdefs[n].l_val = val;
+}
+
+phrase find_label(int n) {
+     phrase val = locdefs[n].l_val;
+     if (val == NULL)
+          error("undefined label %s", locdefs[n].l_lab->s_name);
+     return val;
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/trace.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,115 @@
+/*
+ * trace.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+#define TRACE
+#include "obx.h"
+#include "keiko.h"
+
+struct _opcode { 
+     const char *i_name;        /* Name */
+     const char *i_patt;        /* Argument template */
+     int i_arg;                 /* Argument packed in opcode */
+     int i_len;                 /* Total length in bytes */
+};
+
+#define __o1__(op, inst, patt, arg, len) { #inst, patt, arg, len },
+struct _opcode optable[256] = { __OPCODES__(__o1__) };
+
+char *fmt_inst(uchar *pc) {
+     uchar *args = pc;
+     struct _opcode *ip = &optable[*pc++];
+     static char buf[80];
+     char *s = buf;
+
+     if (ip->i_name == NULL) {
+          strcpy(buf, "UNKNOWN");
+          return buf;
+     }
+
+     s += sprintf(s, "%s", ip->i_name);
+
+     for (const char *p = ip->i_patt; *p != '\0'; p++) {
+          switch (*p) {
+          case '1': case 'K':
+               s += sprintf(s, " %d", get1(pc)); pc++; break;
+          case '2': case 'L':
+               s += sprintf(s, " %d", get2(pc)); pc += 2; break;
+          case 'R':
+               s += sprintf(s, " %ld", (long) (get2(pc)+(args-imem)));
+               pc += 2; break;
+          case 'S':
+               s += sprintf(s, " %ld", (long) (get1(pc)+(args-imem)));
+               pc += 1; break;
+          case 'N':
+               s += sprintf(s, " %d", ip->i_arg); break;
+          default:
+               s += sprintf(s, " ?%c?", *p);
+          }
+     }
+
+     return buf;
+}
+
+void dump(void) {
+     for (int k = 0; k < nprocs; k++) {
+          proc p = proctab[k];
+          value *cp = p->p_addr;
+          uchar *pc, *limit;
+
+          if (! interpreted(cp)) continue;
+          
+          pc = pointer(cp[CP_CODE]); limit = pc + cp[CP_SIZE].i;
+
+          printf("Procedure %s:\n", proctab[k]->p_name);
+          while (pc < limit) {
+               int op = *pc;
+               uchar *pc1 = pc + optable[op].i_len;
+
+               printf("%6ld: %-30s", (long) (pc-imem), fmt_inst(pc));
+               while (pc < pc1) printf(" %d", *pc++);
+               printf("\n");
+
+               if (op == K_JCASE_1) {
+                    int n = pc[-1];
+                    for (int i = 0; i < n; i++) {
+                         printf("%6ld:   CASEL %-22ld %d %d\n",
+                                (long) (pc-imem), (long) (get2(pc)+(pc-imem)),
+                                pc[0], pc[1]);
+                         pc += 2;
+                    }
+               }
+          }
+     }
+}
+
+const char *prim_name(value *p) {
+     if (pointer(p[1]) != NULL) return (char *) pointer(p[1]);
+     return "(unknown)";
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/util.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,212 @@
+/*
+ * util.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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 "config.h"
+#include <stdio.h>
+#include <stdarg.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include <string.h>
+#include "obcommon.h"
+#include "util.h"
+#include <assert.h>
+
+EXTERN int dflag;
+
+char *prog_name;
+
+void error(const char *msg, ...) {
+     va_list va;
+
+     va_start(va, msg);
+     fprintf(stderr, "%s: ", err_file);
+     vfprintf(stderr, msg, va);
+     va_end(va);
+     fprintf(stderr, "\n");
+
+     status = 1;
+}
+
+void panic(const char *msg, ...) {
+     va_list va;
+     mybool bug = FALSE;
+
+     if (*msg == '*') {
+          bug = TRUE; msg++;
+     }
+
+     fprintf(stderr, "%s: Fatal error -- ", progname);
+     va_start(va, msg);
+     vfprintf(stderr, msg, va);
+     va_end(va);
+     if (err_file != NULL)
+       fprintf(stderr, " in %s", err_file);
+     fprintf(stderr, "\n");
+     if (bug)
+          fprintf(stderr, "Please report bugs to %s or %s\n",
+                  PACKAGE_TRACKER, PACKAGE_BUGREPORT);
+
+     exit(2);
+}
+
+/* must_alloc -- malloc or die */
+void *must_alloc(int n, const char *why) {
+     void *p;
+#ifdef DEBUG
+     if (dflag >= 2) printf("Allocating %s as %d", why, n);
+#endif
+     p = malloc(n);
+#ifdef DEBUG
+     if (dflag >= 2) printf(" at %p\n", p);
+#endif
+     if (p == NULL) panic("couldn't allocate space for %s", why);
+     memset(p, 0, n);
+     return p;
+}
+
+/* must_strdup -- strdup or die */
+char *must_strdup(const char *s) {
+     char *p = (char *) must_alloc(strlen(s)+1, s);
+     strcpy(p, s);
+     return p;
+}
+
+/* must_realloc -- realloc or (you guessed it) */
+void *must_realloc(void *p, int n0, int n, const char *msg) {
+#ifdef DEBUG
+     if (dflag >= 2) {
+          printf("Growing %s at %p from %d to %d\n", msg, p, n0, n);
+          fflush(stdout);
+     }
+#endif
+     p = realloc(p, n);
+     if (p == NULL) panic("couldn't expand space for %s", msg);
+     memset(((char *) p) + n0, 0, n-n0);
+     return p;
+}
+
+void _buf_init(struct _growbuf *b, int size, int margin, 
+                       int elsize, const char *name) {
+     b->buf = must_alloc(size * elsize, name);
+     b->loc = 0;
+     b->size = size;
+     b->margin = margin;
+     b->elsize = elsize;
+     b->name = name;
+}
+
+void _buf_grow(struct _growbuf *b) {
+     if (b == NULL) panic("*uninitialized growbuf");
+
+     /* Ensure space for margin+1 items */
+     if (b->loc > b->size - b->margin) {
+          int size1 = max(b->size * GROW, b->loc + b->margin);
+          b->buf = must_realloc(b->buf, b->size * b->elsize, 
+                                size1 * b->elsize, b->name);
+          b->size = size1;
+     }
+}
+
+#define SIZE 10
+#define PAGE 40000
+
+void *pool_alloc(mempool *pool, int size) {
+     void *result;
+
+     assert(size < PAGE);
+
+     if (pool->p_alloc + size > pool->p_pool[pool->p_current] + PAGE) {
+          pool->p_current++;
+          if (pool->p_current >= pool->p_npools) {
+               if (pool->p_npools >= pool->p_size) {
+                    pool->p_pool = (unsigned char **) 
+                         must_realloc(pool->p_pool,
+                                      pool->p_size * sizeof(void *),
+                                      2 * pool->p_size * sizeof(void *),
+                                      "pool table");
+                    pool->p_size *= 2;
+               }
+               pool->p_pool[pool->p_npools++] = 
+                    (uchar *) must_alloc(PAGE, "pools");
+          }
+          pool->p_alloc = pool->p_pool[pool->p_current];
+     }
+
+     result = (void *) pool->p_alloc;
+     pool->p_alloc += size;
+     return result;
+}
+
+void pool_reset(mempool *pool) {
+     if (pool->p_pool == NULL) {
+          pool->p_pool = (unsigned char **)
+               must_alloc(SIZE * sizeof(void *), "pool table");
+          pool->p_pool[0] = (uchar *) must_alloc(PAGE, "pools");
+          pool->p_npools = 1; pool->p_size = SIZE;
+     }
+
+     pool->p_current = 0;
+     pool->p_alloc = pool->p_pool[0];
+}
+
+
+int split_line(char *line, char **words) {
+     int nwords = 0;
+     char *s;
+
+     s = line; 
+     while (*s == ' ' || *s == '\t' || *s == '\r') s++;
+     if (*s == '\n' || *s == '!' || *s == '\0') return 0;
+
+     /* Set the words array */
+     while (1) {
+          while (*s == ' ' || *s == '\t' || *s == '\r') s++;
+          if (*s == '\n' || *s == '\0') break;
+          if (nwords == MAXWORDS) panic("too many words");
+          words[nwords++] = s;
+          while (! isspace((int) *s) && *s != '\0') s++;
+          if (*s == '\n' || *s == '\0') { *s = '\0'; break; }
+          *s++ = '\0';
+     }
+
+     return nwords;
+}
+
+/* squidge -- change Oberon-style name into C identifier */
+char *squidge(char *name) {
+     static char buf[128];
+     char *t = buf;
+
+     for (char *s = name; *s != '\0'; s++)
+          *t++ = ((*s == '.' || *s == '%') ? '_' : *s);
+     *t = '\0';
+
+     return buf;
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/util.h	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,104 @@
+/*
+ * util.h
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+EXTERN char *progname;
+EXTERN char *err_file;
+EXTERN int status;
+
+void error(const char *msg, ...);
+void panic(const char *msg, ...);
+void *must_alloc(int n, const char *msg);
+void *must_realloc(void *p, int n0, int n, const char *msg);
+char *must_strdup(const char *s);
+
+/* Auto-grow buffers */
+
+/*
+To declare an autogrow buffer called A with size N and elements 
+of type T, say:
+
+     PRIVATE growdecl(A);
+     #define A growbuf(A, T)
+     #define N growsize(A)
+
+Remarkably, the macro madness (which appears to define A recursively)
+all works out fine.
+
+To initialize the buffer:
+
+     buf_init(A, init_size, margin, T, "the array A")
+
+The message "Couldn't allocate space for the array A" will be printed
+if allocation fails.
+
+To check that at least |margin| elements remain unused:
+
+     buf_grow(A) 
+*/
+
+#define GROW 1.5                /* Growth ratio when buffer full */
+
+#define growdecl(b) struct _growbuf _##b
+#define growbuf(b, type) ((type *) _##b.buf)
+#define growsize(b) _##b.loc
+#define buf_init(b, size, margin, type, name) \
+     _buf_init(&_##b, size, margin, sizeof(type), name)
+#define buf_grow(b) _buf_grow(&_##b)
+
+struct _growbuf {
+     void *buf;
+     int loc, size, margin;
+     int elsize;
+     const char *name;
+};
+
+void _buf_init(struct _growbuf *b, int size, int margin, 
+                      int elsize, const char *name);
+void _buf_grow(struct _growbuf *b);
+
+
+/* Memory pools */
+
+typedef struct {
+     unsigned char **p_pool;
+     int p_current, p_npools, p_size;
+     uchar *p_alloc;
+} mempool;
+
+void *pool_alloc(mempool *pool, int size);
+void pool_reset(mempool *pool);
+
+
+/* Splitting lines into words */
+
+#define MAXWORDS 16
+int split_line(char *line, char **words);
+
+char *squidge(char *name);
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/keiko/xmain.c	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,594 @@
+/*
+ * xmain.c
+ * 
+ * This file is part of the Oxford Oberon-2 compiler
+ * Copyright (c) 2006--2016 J. M. Spivey
+ * 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. The name of the author may not be used to endorse or promote products
+ *    derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ */
+
+#define EXTERN
+#include "obx.h"
+#include "keiko.h"
+#include "exec.h"
+
+#ifdef JIT
+#include "vm.h"
+#ifdef DEBUG
+#define JTEST 1
+#endif
+#endif
+
+#ifdef PROFILE
+#define MYNAME "profiler"
+#else
+#ifdef OBXDEB
+#define MYNAME "debugging monitor"
+#else
+#define MYNAME "runtime system"
+#endif
+#endif
+
+const char *version = 
+"Oxford Oberon-2 " MYNAME " version " PACKAGE_VERSION " [build " REVID "]"
+#ifdef JIT
+                       " (JIT)"
+#else
+                       ""
+#endif
+#ifdef DEBUG
+                       " (debug)"
+#else
+                       ""
+#endif
+     ;
+const char *copyright = "Copyright (C) 1999--2012 J. M. Spivey";
+
+extern int vm_debug;
+
+/* Helper functions for the loader */
+
+module make_module(char *name, uchar *addr, int chksum, int nlines) {
+     module m = (module) scratch_alloc(sizeof(struct _module));
+     m->m_name = name;
+     m->m_addr = addr;
+#ifdef PROFILE
+     m->m_nlines = nlines;
+     m->m_lcount = NULL;
+     if (lflag && nlines > 0) {
+          m->m_lcount = 
+               (unsigned *) scratch_alloc(nlines * sizeof(unsigned));
+          memset(m->m_lcount, 0, nlines * sizeof(int));
+     }
+#endif
+#ifdef OBXDEB
+     debug_message("module %s %#x", name, chksum);
+#endif
+     return m;
+}
+
+proc make_proc(char *name, uchar *addr) {
+     proc p = (proc) scratch_alloc(sizeof(struct _proc));
+     p->p_name = name;
+     p->p_addr = (value *) addr;
+#ifdef PROFILE
+     p->p_calls = p->p_rec = p->p_self = p->p_child = 0;
+     p->p_parents = p->p_children = NULL;
+#endif
+#ifdef OBXDEB
+     debug_message("proc %s %#x %#x %d", name, address(addr), 
+                   p->p_addr[CP_CODE].a, p->p_addr[CP_SIZE].i);
+#endif
+     return p;
+}
+
+void make_symbol(const char *kind, char *name, uchar *addr) {
+#ifdef OBXDEB
+     debug_message("%s %s %#x", kind, name, address(addr));
+#endif
+}
+
+/* Runtime errors */
+
+#ifndef OBXDEB
+#define TOP 5                   /* Number of frames shown at top and bottom */
+#define BOT 5
+#define GAP 10                  /* Don't omit less than this many frames */
+#define NBUF (BOT+GAP-1)
+
+static void backtrace(value *bp) {
+     value *fp = bp, *cp = valptr(bp[CP]);
+     proc p = find_proc(cp);
+     int n, j;
+     proc fbuf[NBUF];
+     
+     fprintf(stderr, "In procedure %s\n", p->p_name);
+
+     /* Chain down the stack, printing the first TOP frames,
+        and saving the last NBUF in a circular buffer. */
+     for (n = 0;; n++) {
+          /* Each frame contains the cp and bp of its caller */
+          fp = valptr(fp[BP]);  /* Base pointer of next frame */
+          if (fp == NULL) break;
+          cp = valptr(fp[CP]);  /* Constant pool of next frame */
+          fbuf[n%NBUF] = p = find_proc(cp);
+          if (n < TOP)
+               fprintf(stderr, "   called from %s\n", p->p_name);
+     }
+
+     /* Now the last NBUF frames are f(n-NBUF), ..., f(n-1)
+        where f(i) = fbuf[i%NBUF] -- unless there are fewer
+        then NBUF frames in all. */
+
+     if (n < TOP+GAP+BOT) 
+          /* Print the n-TOP frames not printed already */
+          j = TOP;
+     else {
+          /* Omit n-(TOP+BOT) frames (at least GAP) and print the 
+             last BOT frames */
+          fprintf(stderr, "   ... %d intervening frames omitted ...\n", 
+                  n-(TOP+BOT));
+          j = n-BOT;
+     }
+
+     /* Print frames j, ..., n-1 */
+     for (; j < n; j++)
+          fprintf(stderr, "   called from %s\n", fbuf[j%NBUF]->p_name);
+}
+#endif
+
+static const char *message(int code) {
+     switch (code) {
+     case E_CAST:
+          return "dynamic type error in cast";
+     case E_ASSIGN:
+          return "dynamic type error in record assignment";
+     case E_CASE:
+          return "no matching label in CASE statement";
+     case E_WITH:
+          return "no matching type guard in WITH statement";
+     case E_ASSERT:
+          return "assertion failed (%d)";
+     case E_RETURN:
+          return "function failed to return a result";
+     case E_BOUND:
+          return "array bound error";
+     case E_NULL:
+          return "null pointer error";
+     case E_DIV:
+          return "DIV or MOD by zero";
+     case E_FDIV:
+          return "division by zero";
+     case E_STACK:
+          return "stack overflow";
+     case E_GLOB:
+          return "assignment of local procedure";
+     default:
+          return "the impossible has happened";
+     }
+}
+
+/* error_stop -- runtime error with explicit message text */
+void error_stop(const char *msg, int line, value *bp, uchar *pc) {
+     value *cp = valptr(bp[CP]);
+
+#ifdef OBXDEB
+     char buf[256];
+     sprintf(buf, msg, ob_res.i);
+     debug_break(cp, bp, pc, "error %d %s", line, buf);
+#else
+     module mod = find_module(cp);
+
+     fprintf(stderr, "Runtime error: ");
+     fprintf(stderr, msg, ob_res.i);
+     if (line > 0) fprintf(stderr, " on line %d", line);
+     if (mod != NULL && strcmp(mod->m_name, "_Builtin") != 0) 
+          fprintf(stderr, " in module %s", mod->m_name);
+     fprintf(stderr, "\n");
+     fflush(stderr);
+
+     if (nprocs == 0)
+          fprintf(stderr, "(No debugging information available)\n");
+     else if (bp != NULL)
+          backtrace(bp);
+
+     fflush(stderr);
+#endif
+
+     exit(2);
+}
+
+/* runtime_error -- report a runtime error */
+void runtime_error(int m, int line, value *bp, uchar *pc) {
+     error_stop(message(m), line, bp, pc);
+}
+
+/* rterror -- simple version of runtime_error for JIT */
+void rterror(int num, int line, value *bp) {
+     runtime_error(num, line, bp, NULL);
+}
+
+/* stkoflo -- stack overflow handler for JIT */
+void stkoflo(value *bp) {
+     runtime_error(E_STACK, 0, bp, NULL);
+}
+
+
+/* Startup */
+
+static void run(value *prog) {
+     value *sp;
+
+     /* Allow 32-word safety margin (for tracing) */
+     sp = (value *) (stack + stack_size) - 32; 
+
+     sp -= HEAD; 
+     sp[BP].a = address(NULL); 
+     sp[PC].a = address(NULL); 
+     sp[CP].a = address(prog);
+     primcall(prog, sp);
+}
+
+mybool custom_file(char *name) {
+     char buf[4];
+     FILE *fp;
+     int nread;
+     mybool result;
+
+     fp = fopen(name, "rb");
+     if (fp == NULL) return FALSE;
+     fseek(fp, - (long) sizeof(trailer), SEEK_END);
+     nread = fread(buf, 1, 4, fp);
+     if (nread < 4 || strncmp(buf, MAGIC, 4) != 0)
+          result = FALSE;
+     else {
+          fseek(fp, 0, SEEK_SET);
+          nread = fread(buf, 1, 2, fp);
+          result = (nread == 2 && strncmp(buf, "#!", 2) != 0);
+     }
+     fclose(fp);
+     return result;
+}
+ 
+#ifdef WINDOWS
+#include <windows.h>
+#include <winbase.h>
+
+char *search_path(char *name) {
+     static char buf[_MAX_PATH];
+     char *filepart;
+
+     if (SearchPath(NULL, name, ".exe", _MAX_PATH, buf, &filepart) == 0)
+          return NULL;
+
+     return buf;
+}
+#else
+#include <sys/stat.h>
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
+char *search_path(char *name) {
+     char *path;
+     static char buf[256];
+     struct stat stbuf;
+
+     if (name == NULL || strchr(name, '/') != NULL) return name;
+
+     path = getenv("PATH");
+     if (path == NULL) return NULL;
+
+     for (char *p = path, *q; p != NULL; p = q) {
+          q = strchr(p, ':');
+          char *r;
+          if (q == NULL) {
+               strcpy(buf, p);
+               r = buf + strlen(p);
+          } else {
+               strncpy(buf, p, q-p);
+               r = buf + (q-p); q++;
+          }
+          if (r > buf) *r++ = '/';
+          strcpy(r, name);
+
+          if (access(buf, R_OK) == 0 && stat(buf, &stbuf) == 0
+              && S_ISREG(stbuf.st_mode))
+               return buf;
+     }
+
+     return NULL;
+}
+#endif
+
+#define argc saved_argc
+#define argv saved_argv
+
+static char *progname;
+#ifdef PROFILE
+static char *profout;
+static const char *dumpname = "obprof.out";
+#endif
+
+static void usage(void) {
+#ifdef PROFILE
+     fprintf(stderr, 
+             "Usage: %s [-g] [-pl] [-o file] program [arg ...]\n", 
+             progname);
+#else
+     fprintf(stderr, "Usage: %s program [arg ...]\n", progname);
+#endif
+     fflush(stderr);
+     _exit(1);
+}
+
+#ifdef JTEST
+static mybool tflag = 0;
+#endif
+
+/* read_flags -- interpret flags */
+static void read_flags(void) {
+     for (;;) {
+          argc--; argv++;
+          if (argc == 0 || argv[0][0] != '-') return;
+
+          if (strcmp(argv[0], "--") == 0) {
+               argc--; argv++;
+               return;
+          } else if (strcmp(argv[0], "-d") == 0) {
+               dflag++;
+          } else if (strcmp(argv[0], "-v") == 0) {
+               fprintf(stderr, "%s\n", version);
+               exit(0);
+          }
+#ifdef PROFILE
+          else if (argc >= 2 && strcmp(argv[0], "-o") == 0) {
+               profout = argv[1];       
+               argc--; argv++;
+          } else if (strcmp(argv[0], "-g") == 0) {
+               gflag = TRUE;
+          } else if (strcmp(argv[0], "-l") == 0 
+                     || strcmp(argv[0], "-pl") == 0) {
+               lflag = TRUE;
+          }
+#endif
+#ifdef TRACE
+          else if (strcmp(argv[0], "-q") == 0) {
+               qflag++;
+          }
+#endif
+#ifdef OBXDEB
+          else if (argc >= 2 && strcmp(argv[0], "-p") == 0) {
+               debug_socket = argv[1];
+               argc--; argv++;
+          }
+#endif
+#ifdef JTEST
+          else if (strcmp(argv[0], "-t") == 0) {
+               tflag++;
+          }
+#endif
+          else {
+               usage();
+          }
+     }
+}
+
+#ifdef PROFILE
+static void dump_lcounts(void) {
+     FILE *fp = fopen(dumpname, "w");
+     if (fp == NULL) {
+          fprintf(stderr, "%s: cannot write\n", dumpname);
+          exit(1);
+     }
+
+     for (int m = 0; m < nmods; m++)
+          for (int n = 1; n <= modtab[m]->m_nlines; n++)
+               if (modtab[m]->m_lcount[n-1] > 0)
+                    fprintf(fp, "%s %d %u\n", modtab[m]->m_name, n, 
+                            modtab[m]->m_lcount[n-1]);
+
+     fclose(fp);
+}
+
+static void print_profile(void) {
+     FILE *fp = stderr;
+
+     if (profout != NULL) {
+          fp = fopen(profout, "w");
+          if (fp == NULL) {
+               fprintf(stderr, "%s: cannot write\n", profout);
+               exit(1);
+          }
+
+          fprintf(fp, "Command line:\n\n");
+          fprintf(fp, "  %s", saved_argv[0]);
+          for (int i = 1; i < saved_argc; i++)
+               fprintf(fp, " %s", saved_argv[i]);
+          fprintf(fp, "\n\n");
+     }
+
+     profile(fp);
+
+     if (fp != stderr) fclose(fp);
+}
+#endif
+
+#ifdef JTEST
+static void jit_test(void) {
+     dflag = vm_debug = 2; vm_aflag = 1;
+     if (nmods < 2) panic("Can't find main module");
+     module m = modtab[nmods-2];
+     for (int i = 0; i < nprocs; i++) {
+          proc p = proctab[i];
+          if ((uchar *) p->p_addr >= m->m_addr
+              && (uchar *) p->p_addr < m->m_addr + m->m_length)
+               jit_compile(p->p_addr);
+     }
+}
+#endif
+
+/* xmain_exit -- exit after program has finished */
+void NORETURN xmain_exit(int status) {
+#ifdef OBXDEB
+     debug_break(NULL, NULL, NULL, "exit");
+#endif
+#ifdef PROFILE
+     print_profile();
+     if (lflag) dump_lcounts();
+#endif
+     exit(status);
+}
+
+/* error_exit -- exit after fatal error */
+void NORETURN error_exit(int status) {
+#ifdef OBXDEB
+     debug_message("quit");
+#endif
+     exit(status);
+}
+
+/* The interpreter can be invoked in three ways:
+   (i)   Explicitly as "obx [flags] bytefile args"
+
+   (ii)  Via a #! script as "obx bytefile args"
+         or "bytefile bytefile args" under some Unixes
+
+   (iii) In a glued-together executable as "bytefile args"
+
+   Following the example of CAML Light, we recognize (iii) by seeing
+   if argv[0] names a bytefile that does not begin with #!.  In that
+   case, we read that file for the bytecodes, and the program's args
+   follow immediately; otherwise, we look for flags and the name of
+   the bytefile before the program's args.  In either case, we must be
+   prepared to search the shell path to find the bytefile. 
+
+   These rules are modified a bit if a custom file is built for
+   profiling: in that case, we look for switches even in case (iii). */
+
+int main(int ac, char *av[]) {
+     FILE *fp;
+     char *codefile;
+
+     argc = ac; argv = av;
+     progname = argv[0];
+
+     /* Read the command line first to handle -v */
+     codefile = search_path(argv[0]);
+     if (codefile != NULL && custom_file(codefile)) {
+#ifdef PROFILE
+          char *prog = argv[0];
+          read_flags();
+          /* Fill the program name back in as argv[0] */
+          argc++; argv--;
+          argv[0] = prog;
+#endif
+     } else {
+          read_flags();
+          if (argc < 1) usage();
+          codefile = search_path(argv[0]);     
+     }
+
+#ifdef OBXDEB
+     /* Now connect to the debugger process */
+     debug_init();
+#endif
+
+     if (codefile == NULL) panic("can't find %s", argv[0]);
+
+     gc_init();
+
+#ifdef JIT
+     vm_debug = dflag;
+     interpreter = wrap_prim(jit_trap);
+#else
+     interpreter = wrap_prim(interp);
+#endif
+     dyntrap = wrap_prim(dltrap);
+#ifdef USEFFI
+     dynstub = wrap_prim(dlstub);
+#endif
+
+#ifdef M64X32
+     /* Allocate ob_res and statlink in 32-bit addressible storage */
+     _result = (value *) scratch_alloc(2 * sizeof(value));
+     _stat = (value **) scratch_alloc(sizeof(value *));
+#endif
+
+     fp = fopen(codefile, "rb");
+     if (fp == NULL) panic("can't open %s", codefile);
+     load_file(fp);
+     fclose(fp);
+
+#ifdef TRACE
+     if (dflag) dump();
+     if (qflag) exit(0);
+#endif
+
+#ifdef JTEST
+     if (tflag) {
+          jit_test();
+          exit(0);
+     }
+#endif
+
+#ifdef PROFILE
+     if (nprocs == 0) 
+          panic("no symbol table in object file");
+
+     prof_init();
+#endif    
+
+#ifdef OBXDEB
+     debug_break(NULL, NULL, NULL, "ready");
+#endif
+#ifdef DEBUG
+     if (dflag)
+          printf("Starting program at address %ld\n",
+                 (long) ((uchar *) entry - dmem));
+#endif
+     run(entry);
+     xmain_exit(0);
+}
+
+#ifdef JIT
+void interp(value *bp) {
+     panic("dummy interp called");
+}
+#endif
+
+word wrap_prim(primitive *prim) {
+#ifdef JIT
+     return vm_wrap((funptr) prim);
+#else
+#ifndef M64X32
+     return (word) prim;
+#else
+     primitive **wrapper =
+          (primitive **) scratch_alloc(sizeof(primitive *));
+     *wrapper = prim;
+     return address(wrapper);
+#endif
+#endif
+}
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/Makefile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,51 @@
+# lab1/Makefile
+
+all: calc
+
+CALC = lexer.cmo parser.cmo eval.cmo main.cmo
+calc: $(CALC)
+	ocamlc ../lib/common.cma $(CALC) -o $@
+
+parser.mli parser.ml: parser.mly
+	ocamlyacc parser.mly
+
+lexer.ml: lexer.mll
+	ocamllex lexer.mll
+
+clean:
+	rm -f calc parser.mli parser.ml lexer.ml *.cma *.cmo *.cmi 
+
+ML = eval.ml eval.mli lexer.mli lexer.ml main.ml memory.ml memory.mli \
+	parser.mli parser.ml tree.mli
+
+depend : $(ML) force
+	(sed '/^###/q' Makefile; echo; ocamldep $(ML)) >new
+	mv new Makefile
+
+%.cmi : %.mli
+	ocamlc $(MLFLAGS) -c $<
+
+%.cmo : %.ml
+	ocamlc $(MLFLAGS) -c $<
+
+force:
+
+MLFLAGS = -I ../lib
+
+###
+
+eval.cmo: tree.cmi eval.cmi
+eval.cmx: tree.cmi eval.cmi
+eval.cmi: tree.cmi
+lexer.cmi: parser.cmi
+lexer.cmo: parser.cmi lexer.cmi
+lexer.cmx: parser.cmx lexer.cmi
+main.cmo: parser.cmi lexer.cmi eval.cmi
+main.cmx: parser.cmx lexer.cmx eval.cmx
+memory.cmo: memory.cmi
+memory.cmx: memory.cmi
+memory.cmi:
+parser.cmi: tree.cmi
+parser.cmo: tree.cmi parser.cmi
+parser.cmx: tree.cmi parser.cmi
+tree.cmi:
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/eval.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,25 @@
+(* lab1/eval.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree
+
+(* |do_binop| -- compute result of binary operator *)
+let do_binop w v1 v2 =
+  match w with
+      Plus -> v1 +. v2
+    | Minus -> v1 -. v2
+    | Times -> v1 *. v2
+    | Divide -> 
+        if v2 = 0.0 then failwith "dividing by zero";
+        v1 /. v2
+
+(* |eval_expr| -- evaluate an expression *)
+let rec eval_expr =
+  function
+      Number r -> r
+    | Variable x -> failwith "Sorry, I don't do variables"
+    | Binop (w, e1, e2) ->
+        do_binop w (eval_expr e1) (eval_expr e2)
+
+(* |process| -- process an equation, return value of RHS *)
+let process (x, e) = eval_expr e
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/eval.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,5 @@
+(* lab1/eval.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |process| -- process an equation, return value of RHS *)
+val process : string * Tree.expr -> float
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/lexer.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,5 @@
+(* lab1/lexer.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |token| -- scan the next token *)
+val token : Lexing.lexbuf -> Parser.token
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/lexer.mll	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,26 @@
+(* lab1/lexer.mll *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+{
+open Parser 
+open Lexing
+}
+
+rule token = 
+  parse
+      ['A'-'Z''a'-'z']['A'-'Z''a'-'z''0'-'9''_']* as s
+                        { IDENT s }
+    | ['0'-'9']+("."['0'-'9']+)? as s
+                        { NUMBER (float_of_string s) }
+    | "("               { OPEN }
+    | ")"               { CLOSE }
+    | "="               { EQUAL }
+    | "+"               { PLUS }
+    | "-"               { MINUS }
+    | "*"               { TIMES }
+    | "/"               { DIVIDE }
+    | [' ''\t']+        { token lexbuf }
+    | "\n"              { token lexbuf }
+    | _                 { BADTOK }
+    | eof               { EOF }
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/main.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,34 @@
+(* lab1/main.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Eval 
+open Print
+
+(* |parse_equation| -- parse a string as an equation *)
+let parse_equation s = 
+  Parser.equation Lexer.token (Lexing.from_string s)
+
+(* |failure| -- print message after an exception *)
+let failure msg =
+  printf "Failed: $\n" [fStr msg]
+
+(* |main| -- main read-eval-print loop *)
+let main () =
+  printf "Welcome to the world of arithmetic\n" [];
+  try
+    while true do
+      printf "? " []; flush stdout;
+      let line = input_line stdin in
+      try
+        let (x, e) = parse_equation line in
+        let v = process (x, e) in
+        printf "=> $\n" [fFlo v]
+      with
+          Failure msg -> failure msg
+        | Not_found -> failure "not found"
+        | Parsing.Parse_error -> failure "syntax error"
+    done
+  with End_of_file -> 
+    printf "\nBye\n" []
+
+let calc = main ()
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/memory.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,4 @@
+(* lab1/memory.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* YOUR CODE HERE *)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/memory.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,8 @@
+(* lab1/memory.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |store| -- set a memory (named by a string) to a given value *) 
+val store : string -> float -> unit
+
+(* |recall| -- retrieve the value from a given memory, or fail *)
+val recall : string -> float
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/parser.mly	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,36 @@
+/* lab1/parser.mly */
+/* Copyright (c) 2017 J. M. Spivey */
+
+%{
+open Tree
+%}
+
+%token <string>         IDENT
+%token <float>          NUMBER 
+%token                  PLUS MINUS TIMES DIVIDE OPEN CLOSE EQUAL EOF BADTOK
+
+%type <string * Tree.expr>  equation
+
+%start                  equation
+
+%%
+
+equation :
+    expr EOF                            { ("it", $1) }
+  | IDENT EQUAL expr EOF                { ($1, $3) } ;
+
+expr :
+    term                                { $1 }
+  | expr PLUS term                      { Binop (Plus, $1, $3) }
+  | expr MINUS term                     { Binop (Minus, $1, $3) } ;
+
+term :
+    factor                              { $1 }
+  | term TIMES factor                   { Binop (Times, $1, $3) }
+  | term DIVIDE factor                  { Binop (Divide, $1, $3) } ;
+
+factor :
+    NUMBER                              { Number $1 }
+  | IDENT                               { Variable $1 }
+  | OPEN expr CLOSE                     { $2 } ;
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab0/tree.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,11 @@
+(* lab1/tree.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* Abstract syntax *)
+
+type expr =
+    Number of float             (* Constant (value) *)
+  | Variable of string          (* Variable (name) *)
+  | Binop of op * expr * expr   (* Binary operator *)
+
+and op = Plus | Minus | Times | Divide
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/Makefile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,78 @@
+# lab1/Makefile
+
+## Add your own test cases to this list
+TEST = gcd repeat loop case
+
+all: ppc
+
+ppc: keiko.cmo lexer.cmo tree.cmo parser.cmo peepopt.cmo kgen.cmo main.cmo
+	ocamlc ../lib/common.cma $^ -o $@ 
+
+parser.mli parser.ml: parser.mly
+	ocamlyacc -v parser.mly
+
+lexer.ml: lexer.mll
+	ocamllex lexer.mll
+
+tree.cmo: MLFLAGS += -w u
+
+KEIKO = ../keiko
+
+test : force
+	$(MAKE) $(TEST:%=test-%)
+
+test-%: force
+	@echo "*** Test $*.p"
+	./ppc $*.p >a.k
+	$(KEIKO)/pplink -nostdlib $(KEIKO)/lib.k a.k -o a.x >/dev/null
+	$(KEIKO)/ppx ./a.x >a.test
+	sed -n -e '1,/^(\*<</d' -e '/^>>\*)/q' -e p $*.p | diff - a.test
+	@echo "*** Passed"; echo
+
+realclean: clean
+
+clean: force
+	rm -f ppc *.cma *.cmo *.cmi
+	rm -f parser.mli parser.ml lexer.ml parser.output
+	rm -f a.k a.out a.x a.test
+
+ML = keiko.ml keiko.mli kgen.ml kgen.mli lexer.mli \
+	lexer.ml main.ml parser.mli parser.ml tree.ml tree.mli \
+	peepopt.mli peepopt.ml
+
+depend : $(ML) force
+	(sed '/^###/q' Makefile; echo; ocamldep $(ML)) >new
+	mv new Makefile
+
+%.cmi : %.mli
+	ocamlc $(MLFLAGS) -c $<
+
+%.cmo : %.ml
+	ocamlc $(MLFLAGS) -c $<
+
+force:
+
+MLFLAGS = -I ../lib
+
+###
+
+keiko.cmo : tree.cmi keiko.cmi
+keiko.cmx : tree.cmx keiko.cmi
+keiko.cmi :
+kgen.cmo : tree.cmi peepopt.cmi keiko.cmi kgen.cmi
+kgen.cmx : tree.cmx peepopt.cmx keiko.cmx kgen.cmi
+kgen.cmi : tree.cmi
+lexer.cmo : tree.cmi parser.cmi keiko.cmi lexer.cmi
+lexer.cmx : tree.cmx parser.cmx keiko.cmx lexer.cmi
+lexer.cmi : tree.cmi parser.cmi
+main.cmo : tree.cmi parser.cmi lexer.cmi kgen.cmi
+main.cmx : tree.cmx parser.cmx lexer.cmx kgen.cmx
+parser.cmo : tree.cmi lexer.cmi keiko.cmi parser.cmi
+parser.cmx : tree.cmx lexer.cmx keiko.cmx parser.cmi
+parser.cmi : tree.cmi keiko.cmi
+peepopt.cmo : keiko.cmi peepopt.cmi
+peepopt.cmx : keiko.cmx peepopt.cmi
+peepopt.cmi : keiko.cmi
+tree.cmo : keiko.cmi tree.cmi
+tree.cmx : keiko.cmx tree.cmi
+tree.cmi : keiko.cmi
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/case.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,27 @@
+(* lab1/case.p *)
+
+begin
+  i := 0;
+  while i < 10 do
+    case i of
+      1, 3, 5:
+        i := i + 1;
+        i := i + 2
+    | 2, 6: 
+        i := i - 1;
+    | 8:
+        i := i + 2;
+    else
+      i := i + 1
+    end;
+    print i; newline
+  end
+end.
+
+(*<<
+ 1
+ 4
+ 5
+ 8
+ 10
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/compile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,13 @@
+#!/bin/sh
+
+# This hacked up version works, at least on Linux, even for people who
+# have spaces in the names of directories.  Sheesh.
+
+KEIKO=`cd ../keiko; pwd`
+
+set -x
+
+./ppc $* >a.k \
+    && "$KEIKO/pplink" -nostdlib -i "/usr/bin/env $KEIKO/ppx" \
+        "$KEIKO/lib.k" a.k -o a.out >/dev/null \
+    && chmod +x a.out
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/gcd.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,17 @@
+(* lab1/gcd.p *)
+
+begin
+  x := 3 * 37; y := 5 * 37;
+  while x <> y do
+    if x > y then
+      x := x - y
+    else
+      y := y - x
+    end
+  end;
+  print x; newline
+end.
+
+(*<<
+ 37
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/keiko.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,276 @@
+(* common/keiko.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree 
+open Print
+
+(* |codelab| -- type of code labels *)
+type codelab = int
+
+(* |lastlab| -- last used code label *)
+let lastlab = ref 0
+
+(* |label| -- allocate a code label *)
+let label () = incr lastlab; !lastlab
+
+(* |fLab| -- format a code label for printf *)
+let fLab n = fMeta "L$" [fNum n]
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
+
+(* |code| -- type of intermediate instructions *)
+type code =
+    CONST of int                (* Push constant (value) *)
+  | GLOBAL of string            (* Push global address (name) *)
+  | LOCAL of int                (* Push local adddress (offset) *)
+  | LOADW                       (* Load word *)
+  | STOREW                      (* Store word *)
+  | LOADC                       (* Load character *)
+  | STOREC                      (* Store character *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (op, dest) *)
+  | PCALL of int                (* Call procedure *)
+  | PCALLW of int               (* Proc call with result (nargs) *)
+  | RETURNW                     (* Return from procedure *)
+  | BOUND of int                (* Bounds check *)
+  | CASEJUMP of int             (* Case jump (num cases) *)
+  | CASEARM of int * codelab    (* Case value and label *)
+  | PACK                        (* Pack two values into one *)
+  | UNPACK                      (* Unpack one value into two *)
+  | DUP
+  | POP
+
+  | LDGW of string              (* Load Global Word (name) *)
+  | STGW of string              (* Store Global Word (name) *)
+  | LDLW of int                 (* Load Local Word (offset) *)
+  | STLW of int                 (* Store Local Word (offset) *)
+  | LDNW of int                 (* Load word with offset *)
+  | STNW of int                 (* Store word with offset *)
+
+  | LINE of int
+  | SEQ of code list
+  | NOP
+
+(* op_name -- map an operator to its name *)
+let op_name =
+  function
+      Plus -> "Plus" | Minus -> "Minus" | Times -> "Times"
+    | Div -> "Div" | Mod -> "Mod" | Eq -> "Eq"
+    | Uminus -> "Uminus" | Lt -> "Lt" | Gt -> "Gt" 
+    | Leq -> "Leq" | Geq -> "Geq" | Neq -> "Neq" 
+    | And -> "And" | Or -> "Or" | Not -> "Not"
+
+(* fOp -- format an operator as an instruction *)
+let fOp w =
+  (* Avoid the deprecated String.uppercase *)
+  let upc ch =
+    if ch >= 'a' && ch <= 'z' then Char.chr (Char.code ch - 32) else ch in
+  fStr (String.map upc (op_name w))
+
+(* |fInst| -- format an instruction for |printf| *)
+let fInst =
+  function
+      CONST x ->        fMeta "CONST $" [fNum x]
+    | GLOBAL a ->       fMeta "GLOBAL $" [fStr a]
+    | LOCAL n ->        fMeta "LOCAL $" [fNum n]
+    | LOADW ->          fStr "LOADW"
+    | STOREW ->         fStr "STOREW"
+    | LOADC ->          fStr "LOADC"
+    | STOREC ->         fStr "STOREC"
+    | MONOP w ->        fOp w
+    | BINOP w ->        fOp w
+    | OFFSET ->         fStr "OFFSET"
+    | LABEL l ->        fMeta "LABEL $" [fLab l]
+    | JUMP l ->         fMeta "JUMP $" [fLab l]
+    | JUMPC (w, l) ->   fMeta "J$ $" [fOp w; fLab l]
+    | PCALL n ->        fMeta "PCALL $" [fNum n]
+    | PCALLW n ->       fMeta "PCALLW $" [fNum n]
+    | RETURNW ->        fStr "RETURNW"
+    | BOUND n ->        fMeta "BOUND $" [fNum n]
+    | CASEJUMP n ->     fMeta "CASEJUMP $" [fNum n]
+    | CASEARM (v, l) -> fMeta "CASEARM $ $" [fNum v; fLab l]
+    | PACK ->           fStr "PACK"
+    | UNPACK ->         fStr "UNPACK"
+    | DUP ->            fStr "DUP 0"
+    | POP ->            fStr "POP 1"
+    | LDGW a ->         fMeta "LDGW $" [fStr a]
+    | STGW a ->         fMeta "STGW $" [fStr a]
+    | LDLW n ->         fMeta "LDLW $" [fNum n]
+    | STLW n ->         fMeta "STLW $" [fNum n]
+    | LDNW n ->         fMeta "LDNW $" [fNum n]
+    | STNW n ->         fMeta "STNW $" [fNum n]
+    | LINE n ->         fMeta "LINE $" [fNum n]
+    | SEQ _ ->          fStr "SEQ ..."
+    | NOP ->            fStr "NOP"
+
+let mark_line n ys =
+  if n = 0 then ys else
+    match ys with
+        [] | LINE _ :: _ -> ys
+      | _ -> LINE n :: ys
+
+(* |canon| -- flatten a code sequence *)
+let canon x =
+  let rec accum x ys =
+    match x with
+        SEQ xs -> List.fold_right accum xs ys
+      | NOP -> ys
+      | LINE n -> 
+          if n = 0 then 
+            ys 
+          else begin
+            match ys with
+                [] -> ys
+              | LINE _ :: _ -> ys
+              | _ -> LINE n :: ys
+          end
+      | _ -> x :: ys in
+  SEQ (accum x [])
+
+
+(* SANITY CHECKS *)
+
+(* The checks implemented here ensure that the value stack is used in a 
+   consistent way, and that CASEJUMP instructions are followed by the 
+   correct number of case labels.  There are a few assumptions, the main
+   one being that backwards jumps leave nothing on the stack. *)
+
+(* Compute pair (a, b) if an instruction pops a values and pushes b *)
+let delta =
+  function
+      CONST _ | GLOBAL _ | LOCAL _ | LDGW _ | LDLW _ -> (0, 1)
+    | STGW _ | STLW _ -> (1, 0)
+    | LOADW | LOADC | LDNW _ -> (1, 1)
+    | STOREW | STOREC | STNW _ -> (2, 0)
+    | MONOP _ -> (1, 1)
+    | BINOP _ | OFFSET -> (2, 1)
+    | PCALL n -> (n+2, 0)
+    | PCALLW n -> (n+2, 1)
+    | RETURNW -> (1, 0)
+    | BOUND _ -> (2, 1)
+    | PACK -> (2, 1)
+    | UNPACK -> (1, 2)
+    | LINE _ -> (0, 0)
+    | DUP -> (1, 2)
+    | POP -> (1, 0)
+    | i -> failwith (sprintf "delta $" [fInst i])
+
+(* Output code and check for basic sanity *)
+let check_and_output code =
+  let line = ref 0 in
+
+  (* Output an instruction *)
+  let out =
+    function 
+        LINE n -> 
+          if n <> 0 && !line <> n then begin
+            printf "! $\n" [fStr (Source.get_line n)];
+            line := n
+          end
+      | x -> printf "$\n" [fInst x] in
+
+  (* Report failure of sanity checks *)
+  let insane fmt args =
+    fprintf stderr "WARNING: Code failed sanity checks -- $\n" [fMeta fmt args];
+    printf "! *** HERE!\n" [];
+    raise Exit in
+
+  (* Map labels to (depth, flag) pairs *)
+  let labdict = Hashtbl.create 50 in
+
+  (* Note the depth at a label and check for consistency *)
+  let note_label lab def d =
+    try 
+      let (d1, f) = Hashtbl.find labdict lab in
+      if d >= 0 && d <> d1 then
+        insane "inconsistent stack depth ($ <> $) at label $" 
+          [fNum d; fNum d1; fNum lab];
+      if def then begin
+        if !f then insane "multiply defined label $" [fNum lab];
+        f := true
+      end;
+      d1
+    with Not_found ->
+      (* If this point is after an unconditional jump (d < 0) and 
+         the label is not defined previously, assume depth 0 *)
+      let d1 = max d 0 in
+      Hashtbl.add labdict lab (d1, ref def);
+      d1 in
+
+  (* Check all mentioned labels have been defined *)
+  let check_labs () =
+    Hashtbl.iter (fun lab (d, f) -> 
+      if not !f then insane "label $ is not defined" [fNum lab]) labdict in
+
+  let tail = ref [] in
+
+  let output () = out (List.hd !tail); tail := List.tl !tail in
+
+  (* Scan an instruction sequence, keeping track of the stack depth *)
+  let rec scan d = 
+    match !tail with
+        [] -> 
+          if d <> 0 then insane "stack not empty at end" []
+      | x :: _ ->
+          let need a =
+            if d < a then 
+              insane "stack underflow at instruction $" [fInst x] in
+          output ();
+          begin match x with
+              LABEL lab -> 
+                scan (note_label lab true d)
+            | JUMP lab -> 
+                unreachable (note_label lab false d)
+            | JUMPC (_, lab) -> 
+                need 2; scan (note_label lab false (d-2))
+            | CASEARM (_, _) -> 
+                insane "unexpected CASEARM" []
+            | CASEJUMP n -> 
+                need 1; jumptab n (d-1)
+            | SEQ _ | NOP -> 
+                failwith "sanity2"
+            | _ -> 
+                let (a, b) = delta x in need a; scan (d-a+b)
+          end
+
+  (* Scan a jump table, checking for the correct number of entries *)
+  and jumptab n d =
+    match !tail with
+        CASEARM (_, lab) :: _ -> 
+          output ();
+          if n = 0 then
+            insane "too many CASEARMs after CASEJUMP" [];
+          jumptab (n-1) (note_label lab false d)
+      | _ -> 
+          if n > 0 then
+            insane "too few CASEARMs after CASEJUMP" [];
+          scan d
+
+  (* Scan code after an unconditional jump *)
+  and unreachable d =
+    match !tail with
+        [] -> ()
+      | LABEL lab :: _ ->
+          output ();
+          scan (note_label lab true (-1))
+      | _ -> 
+          (* Genuinely unreachable code -- assume stack is empty *)
+          scan 0 in
+
+  match canon code with
+      SEQ xs -> 
+        tail := xs; 
+        (try scan 0; check_labs () with Exit -> 
+          (* After error, output rest of code without checks *)
+          List.iter out !tail; exit 1)
+    | _ -> failwith "sanity"
+
+let output code = 
+  try check_and_output code with Exit -> exit 1
+    
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/keiko.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,61 @@
+(* common/keiko.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |codelab| -- type of code labels *)
+type codelab = int
+
+(* |label| -- allocate a code label *)
+val label : unit -> codelab
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
+
+(* op_name -- map an operator to its name *)
+val op_name : op -> string
+
+(* |code| -- type of intermediate instructions *)
+type code =
+    CONST of int                (* Push constant (value) *)
+  | GLOBAL of string            (* Push global address (name) *)
+  | LOCAL of int                (* Push local adddress (offset) *)
+  | LOADW                       (* Load word *)
+  | STOREW                      (* Store word *)
+  | LOADC                       (* Load character *)
+  | STOREC                      (* Store character *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (op, dest) *)
+  | PCALL of int                (* Call procedure *)
+  | PCALLW of int               (* Proc call with result (nargs) *)
+  | RETURNW                     (* Return from procedure *)
+  | BOUND of int                (* Bounds check *)
+  | CASEJUMP of int             (* Case jump (num cases) *)
+  | CASEARM of int * codelab    (* Case value and label *)
+  | PACK                        (* Pack two values into one *)
+  | UNPACK                      (* Unpack one value into two *)
+  | DUP
+  | POP
+
+  | LDGW of string              (* Load Global Word (name) *)
+  | STGW of string              (* Store Global Word (name) *)
+  | LDLW of int                 (* Load Local Word (offset) *)
+  | STLW of int                 (* Store Local Word (offset) *)
+  | LDNW of int                 (* Load word with offset *)
+  | STNW of int                 (* Store word with offset *)
+
+  | LINE of int
+  | SEQ of code list
+  | NOP
+
+(* |fInst| -- format an instruction for |printf| *)
+val fInst : code -> Print.arg
+
+(* |canon| -- flatten a code sequence *)
+val canon : code -> code
+
+(* |output| -- output a code sequence *)
+val output : code -> unit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/kgen.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,64 @@
+(* lab1/kgen.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree
+open Keiko
+
+let optflag = ref false
+
+(* |gen_expr| -- generate code for an expression *)
+let rec gen_expr =
+  function
+      Constant x ->
+        CONST x
+    | Variable x ->
+        SEQ [LINE x.x_line; LDGW x.x_lab]
+    | Monop (w, e1) ->
+        SEQ [gen_expr e1; MONOP w]
+    | Binop (w, e1, e2) ->
+        SEQ [gen_expr e1; gen_expr e2; BINOP w]
+
+(* |gen_cond| -- generate code for short-circuit condition *)
+let rec gen_cond e tlab flab =
+  (* Jump to |tlab| if |e| is true and |flab| if it is false *)
+  match e with
+      Constant x ->
+        if x <> 0 then JUMP tlab else JUMP flab
+    | Binop ((Eq|Neq|Lt|Gt|Leq|Geq) as w, e1, e2) ->
+        SEQ [gen_expr e1; gen_expr e2; JUMPC (w, tlab); JUMP flab]
+    | Monop (Not, e1) ->
+        gen_cond e1 flab tlab
+    | Binop (And, e1, e2) ->
+        let lab1 = label () in
+        SEQ [gen_cond e1 lab1 flab; LABEL lab1; gen_cond e2 tlab flab]
+    | Binop (Or, e1, e2) ->
+        let lab1 = label () in
+        SEQ [gen_cond e1 tlab lab1; LABEL lab1; gen_cond e2 tlab flab]
+    | _ ->
+        SEQ [gen_expr e; CONST 0; JUMPC (Neq, tlab); JUMP flab]
+
+(* |gen_stmt| -- generate code for a statement *)
+let rec gen_stmt s =
+  match s with
+      Skip -> NOP
+    | Seq stmts -> SEQ (List.map gen_stmt stmts)
+    | Assign (v, e) ->
+        SEQ [LINE v.x_line; gen_expr e; STGW v.x_lab]
+    | Print e ->
+        SEQ [gen_expr e; CONST 0; GLOBAL "lib.print"; PCALL 1]
+    | Newline ->
+        SEQ [CONST 0; GLOBAL "lib.newline"; PCALL 0]
+    | IfStmt (test, thenpt, elsept) ->
+        let lab1 = label () and lab2 = label () and lab3 = label () in
+        SEQ [gen_cond test lab1 lab2; 
+          LABEL lab1; gen_stmt thenpt; JUMP lab3;
+          LABEL lab2; gen_stmt elsept; LABEL lab3]
+    | WhileStmt (test, body) ->
+        let lab1 = label () and lab2 = label () and lab3 = label () in
+        SEQ [JUMP lab2; LABEL lab1; gen_stmt body; 
+          LABEL lab2; gen_cond test lab1 lab3; LABEL lab3]
+
+(* |translate| -- generate code for the whole program *)
+let translate (Program ss) =
+  let code = gen_stmt ss in
+  Keiko.output (if !optflag then Peepopt.optimise code else code)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/kgen.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,8 @@
+(* lab1/kgen.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* translate -- generate intermediate code *)
+val translate : Tree.program -> unit
+
+(* optflag -- flag to control optimisation *)
+val optflag : bool ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/lexer.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,11 @@
+(* lab1/lexer.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |token| -- scan a token and return its code *)
+val token : Lexing.lexbuf -> Parser.token
+
+(* |lineno| -- number of current line *)
+val lineno : int ref
+
+(* |get_vars| -- list of identifiers used in program *)
+val get_vars : unit -> Tree.ident list
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/lexer.mll	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,77 @@
+(* lab1/lexer.mll *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+{
+open Lexing
+open Tree 
+open Keiko
+open Parser
+
+(* |lineno| -- line number for use in error messages *)
+let lineno = ref 1
+
+(* |make_hash| -- create hash table from list of pairs *)
+let make_hash n ps =
+  let t = Hashtbl.create n in
+  List.iter (fun (k, v) -> Hashtbl.add t k v) ps;
+  t
+
+(* |kwtable| -- a little table to recognize keywords *)
+let kwtable = 
+  make_hash 64
+    [ ("begin", BEGIN); ("do", DO); ("if", IF ); ("else", ELSE); 
+      ("end", END); ("then", THEN); ("while", WHILE); ("print", PRINT);
+      ("newline", NEWLINE); ("and", MULOP And); ("div", MULOP Div); 
+      ("or", ADDOP Or); ("not", MONOP Not); ("mod", MULOP Mod);
+      ("true", NUMBER 1); ("false", NUMBER 0) ]
+
+(* |idtable| -- table of all identifiers seen so far *)
+let idtable = Hashtbl.create 64
+
+(* |lookup| -- convert string to keyword or identifier *)
+let lookup s = 
+  try Hashtbl.find kwtable s with 
+    Not_found -> 
+      Hashtbl.replace idtable s ();
+      IDENT s
+
+(* |get_vars| -- get list of identifiers in the program *)
+let get_vars () = 
+  Hashtbl.fold (fun k () ks -> k::ks) idtable []
+}
+
+rule token = 
+  parse
+      ['A'-'Z''a'-'z']['A'-'Z''a'-'z''0'-'9''_']* as s
+                        { lookup s }
+    | ['0'-'9']+ as s   { NUMBER (int_of_string s) }
+    | ";"               { SEMI }
+    | "."               { DOT }
+    | ":"               { COLON }
+    | "("               { LPAR }
+    | ")"               { RPAR }
+    | ","               { COMMA }
+    | "="               { RELOP Eq }
+    | "+"               { ADDOP Plus }
+    | "-"               { MINUS }
+    | "*"               { MULOP Times }
+    | "<"               { RELOP Lt }
+    | ">"               { RELOP Gt }
+    | "<>"              { RELOP Neq }
+    | "<="              { RELOP Leq }
+    | ">="              { RELOP Geq }
+    | ":="              { ASSIGN }
+    | [' ''\t']+        { token lexbuf }
+    | "(*"              { comment lexbuf; token lexbuf }
+    | "\n"              { incr lineno; Source.note_line !lineno lexbuf;
+                          token lexbuf }
+    | _                 { BADTOK }
+    | eof               { EOF }
+
+and comment = 
+  parse
+      "*)"              { () }
+    | "\n"              { incr lineno; Source.note_line !lineno lexbuf;
+                          comment lexbuf }
+    | _                 { comment lexbuf }
+    | eof               { () }
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/loop.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,29 @@
+(* lab1/loop.p *)
+
+begin
+  x := 12345;
+  i := 1;
+  loop
+    print i; newline;
+    j := 2 * i; 
+    if j > x then exit end;
+    i := j
+  end
+end.
+
+(*<<
+ 1
+ 2
+ 4
+ 8
+ 16
+ 32
+ 64
+ 128
+ 256
+ 512
+ 1024
+ 2048
+ 4096
+ 8192
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/main.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,48 @@
+(* lab1/main.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Print
+
+(* |main| -- main program *)
+let main () =
+  let dflag = ref 0 in
+  let fns = ref [] in
+  let usage =  "Usage: ppc [-d] file.p" in
+  Arg.parse 
+    [("-d", Arg.Unit (fun () -> incr dflag), " Print the tree for debugging");
+      ("-O", Arg.Unit (fun () -> Kgen.optflag := true), " Peephole optimiser")]
+    (function s -> fns := !fns @ [s]) usage;
+  if List.length !fns <> 1 then begin 
+    fprintf stderr "$\n" [fStr usage]; exit 2 
+  end;
+
+  let in_file = List.hd !fns in
+  let in_chan = open_in in_file in
+  Source.init in_file in_chan;
+  ignore (Parsing.set_trace (!dflag > 1));
+  let lexbuf = Lexing.from_channel in_chan in
+  let prog = try Parser.program Lexer.token lexbuf with
+      Parsing.Parse_error ->
+        let tok = Lexing.lexeme lexbuf in
+        Source.err_message "syntax error at token '$'" 
+          [fStr tok] !Lexer.lineno;
+        exit 1 in
+
+  if !dflag > 0 then Tree.print_tree stdout prog;
+
+  printf "MODULE Main 0 0\n" [];
+  printf "IMPORT Lib 0\n" [];
+  printf "ENDHDR\n\n" [];
+
+  printf "PROC MAIN 0 0 0\n" [];
+  Kgen.translate prog;
+  printf "RETURN\n" [];
+  printf "END\n\n" [];
+
+  List.iter 
+    (fun x -> printf "GLOVAR _$ 4\n" [fStr x]) 
+    (Lexer.get_vars ());
+
+  exit 0
+
+let ppc = main ()
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/parser.mly	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,64 @@
+/* lab1/parser.mly */
+/* Copyright (c) 2017 J. M. Spivey */
+
+%{ 
+open Keiko
+open Tree
+%}
+
+%token <Tree.ident>     IDENT
+%token <Keiko.op>       MONOP MULOP ADDOP RELOP
+%token <int>            NUMBER
+
+/* punctuation and keywords */
+%token                  SEMI DOT COLON LPAR RPAR COMMA MINUS VBAR
+%token                  ASSIGN EOF BADTOK
+%token                  BEGIN DO ELSE END IF THEN WHILE PRINT NEWLINE
+
+%type <Tree.program>    program
+
+%start                  program
+
+%%
+
+program :       
+    BEGIN stmts END DOT                 { Program $2 } ;
+
+stmts : 
+    stmt_list                           { seq $1 } ;
+
+stmt_list :
+    stmt                                { [$1] }
+  | stmt SEMI stmt_list                 { $1 :: $3 } ;
+
+stmt :  
+    /* empty */                         { Skip }
+  | name ASSIGN expr                    { Assign ($1, $3) }
+  | PRINT expr                          { Print $2 }
+  | NEWLINE                             { Newline }
+  | IF expr THEN stmts END              { IfStmt ($2, $4, Skip) }
+  | IF expr THEN stmts ELSE stmts END   { IfStmt ($2, $4, $6) }
+  | WHILE expr DO stmts END             { WhileStmt ($2, $4) } ;
+ 
+expr :
+    simple                              { $1 }
+  | expr RELOP simple                   { Binop ($2, $1, $3) } ;
+    
+simple :
+    term                                { $1 }
+  | simple ADDOP term                   { Binop ($2, $1, $3) }
+  | simple MINUS term                   { Binop (Minus, $1, $3) } ;
+
+term :
+    factor                              { $1 }
+  | term MULOP factor                   { Binop ($2, $1, $3) } ;
+
+factor :
+    name                                { Variable $1 }
+  | NUMBER                              { Constant $1 }
+  | MONOP factor                        { Monop ($1, $2) }
+  | MINUS factor                        { Monop (Uminus, $2) }
+  | LPAR expr RPAR                      { $2 } ;
+
+name :
+    IDENT                               { make_name $1 !Lexer.lineno } ;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/peepopt.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,172 @@
+(* ppc/peepopt.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Keiko
+open Print
+
+let debug = ref 0
+
+(* Disjoint sets of labels *)
+
+type lab_data = 
+    LabDef of labrec                    (* An extant label *)
+  | Equiv of codelab                    (* A label that's been merged *)
+
+and labrec =
+  { y_id: codelab;                      (* Name of the label *)
+    y_refct: int ref }                  (* Reference count *)
+
+(* |label_tab| -- map labels to their equivalents *)
+let label_tab = Hashtbl.create 257
+
+(* |get_label| -- get equivalence cell for a label *)
+let get_label x =
+  try !(Hashtbl.find label_tab x) with
+    Not_found ->
+      let y = LabDef { y_id = x; y_refct = ref 0 } in
+      Hashtbl.add label_tab x (ref y); y
+
+(* |find_label| -- find data about equivalence class of a label *)
+let rec find_label x =
+  match get_label x with
+      LabDef y -> y
+    | Equiv x' -> find_label x'
+
+(* |rename| -- get canonical equivalent of a label *)
+let rename x = let y = find_label x in y.y_id
+
+(* |ref_count| -- get reference count cell for a label *)
+let ref_count x = let y = find_label x in y.y_refct
+
+(* |same_lab| -- test if two labels are equivalent *)
+let same_lab x1 x2 = (rename x1 = rename x2)
+
+(* |equate| -- make two labels equivalent *)
+let equate x1 x2 =
+  let y1 = find_label x1 and y2 = find_label x2 in
+  if y1.y_id = y2.y_id then failwith "equate";
+  y2.y_refct := !(y1.y_refct) + !(y2.y_refct);
+  Hashtbl.find label_tab y1.y_id := Equiv y2.y_id
+
+(* |do_refs| -- call function on refcount of each label in an instruction *)
+let do_refs f =
+  function
+      JUMP x -> f (ref_count x)
+    | JUMPC (w, x) -> f (ref_count x)
+    | CASEARM (n, x) -> f (ref_count x)
+    | _ -> ()
+
+(* |rename_labs| -- replace each label by its equivalent *)
+let rename_labs =
+  function
+      LABEL x -> LABEL (rename x)
+    | JUMP x -> JUMP (rename x)
+    | JUMPC (w, x) -> JUMPC (w, rename x)
+    | CASEARM (n, x) -> CASEARM (n, rename x)
+    | i -> i
+
+let opposite =
+  function Eq -> Neq | Neq -> Eq | Lt  -> Geq
+    | Leq -> Gt | Gt  -> Leq | Geq -> Lt
+    | _ -> failwith "opposite"
+
+(* |ruleset| -- simplify and introduce abbreviations *)
+let ruleset replace =
+  function
+      LOCAL a :: CONST b :: OFFSET :: _ ->
+        replace 3 [LOCAL (a+b)]
+    | CONST a :: OFFSET :: CONST b :: OFFSET :: _ ->
+        replace 4 [CONST (a+b); OFFSET]
+    | CONST 0 :: OFFSET :: _ ->
+        replace 2 []
+     
+    | GLOBAL x :: LOADW :: _ ->
+        replace 2 [LDGW x]
+    | GLOBAL x :: STOREW :: _ ->
+        replace 2 [STGW x]
+    | LOCAL n :: LOADW :: _ ->
+        replace 2 [LDLW n]
+    | LOCAL n :: STOREW :: _ ->
+        replace 2 [STLW n]
+    | CONST n :: OFFSET :: LOADW :: _ ->
+        replace 3 [LDNW n]
+    | CONST n :: OFFSET :: STOREW :: _ ->
+        replace 3 [STNW n]
+
+    | CONST x :: CONST n :: BOUND _ :: _ when x >= 0 && x < n ->
+        replace 3 [CONST x]
+
+    | LINE n :: LABEL a :: _ ->
+        replace 2 [LABEL a; LINE n]
+    | LINE n :: LINE m :: _ ->
+        replace 1 []
+    | LABEL a :: LABEL b :: _ ->
+        equate a b; replace 2 [LABEL a]
+    | LABEL a :: JUMP b :: _ when not (same_lab a b) ->
+        equate a b; replace 2 [JUMP b]
+    | JUMPC (w, a) :: JUMP b :: LABEL c :: _ when same_lab a c ->
+        replace 2 [JUMPC (opposite w, b)]
+    | JUMP a :: LABEL b :: _ when same_lab a b ->
+        replace 1 []
+    | JUMP a :: LABEL b :: _ -> 
+        ()
+    | JUMP a :: _ :: _ ->
+        replace 2 [JUMP a]
+    | LABEL a :: _ when !(ref_count a) = 0 ->
+        replace 1 []
+
+    | _ -> ()
+
+(* |take n [x1; x2; ...] = [x1; x2; ...; xn]| *)
+let rec take n =
+  function
+      [] -> []
+    | x::xs -> if n = 0 then [] else x :: take (n-1) xs
+
+(* |drop n [x1; x2; ...] = [x_{n+1}; x_{n+2}; ...]| *)
+let rec drop n =
+  function
+      [] -> []
+    | x::xs -> if n = 0 then x::xs else drop (n-1) xs
+
+(* |optstep| -- apply rules at one place in the buffer *)
+let optstep rules changed code =
+  let ch = ref true in
+  let replace n c = 
+    changed := true; ch := true;
+  if !debug > 0 then
+      printf "! $ --> $\n" [fList(fInst) (take n !code); fList(fInst) c];
+    List.iter (do_refs decr) (take n !code);
+    List.iter (do_refs incr) c; 
+    code := c @ drop n !code in
+  while !ch do
+    ch := false; rules replace !code
+  done
+
+(* |rewrite| -- iterate over the code and apply rules *)
+let rewrite rules prog =
+  let code1 = ref prog and code2 = ref [] in
+  let changed = ref true in
+  while !changed do
+    changed := false;
+    while !code1 <> [] do
+      optstep rules changed code1;
+      if !code1 <> [] then begin
+        code2 := rename_labs (List.hd !code1) :: !code2;
+        code1 := List.tl !code1
+      end
+    done;
+    code1 := List.rev !code2;
+    code2 := []
+  done;
+  !code1
+
+(* |optimise| -- rewrite list of instructions *)
+let optimise prog =
+  match Keiko.canon prog with
+      SEQ code ->
+        List.iter (do_refs incr) code;
+        let code2 = rewrite ruleset code in
+        Hashtbl.clear label_tab;
+        SEQ code2
+    | _ -> failwith "optimise"
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/peepopt.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,8 @@
+(* ppc/peepopt.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |optimise| -- rewrite list of instructions *)
+val optimise : Keiko.code -> Keiko.code
+
+(* |debug| -- debugging level *)
+val debug: int ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/repeat.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,16 @@
+(* lab1/repeat.p *)
+
+begin
+  i := 0;
+  repeat
+    i := i + 1; 
+    i := i * i;
+    print i; newline
+  until i mod 5 = 0
+end.
+
+(*<<
+ 1
+ 4
+ 25
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/tree.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,99 @@
+(* lab1/tree.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+type ident = string
+
+(* |name| -- type for applied occurrences, with annotations *)
+type name = 
+  { x_name: ident;              (* Name of the reference *)
+    x_lab: string;              (* Global label *)
+    x_line: int }               (* Line number *)
+
+let make_name x ln = { x_name = x; x_lab = "_" ^ x; x_line = ln }
+
+
+(* Abstract syntax *)
+type program = Program of stmt
+
+and stmt = 
+    Skip 
+  | Seq of stmt list
+  | Assign of name * expr
+  | Print of expr
+  | Newline
+  | IfStmt of expr * stmt * stmt
+  | WhileStmt of expr * stmt
+
+and expr = 
+    Constant of int 
+  | Variable of name
+  | Monop of Keiko.op * expr 
+  | Binop of Keiko.op * expr * expr
+
+let seq =
+  function
+      [] -> Skip                (* Use Skip in place of Seq [] *)
+    | [s] -> s                  (* Don't use a Seq node for one element *)
+    | ss -> Seq ss
+
+
+(* Pretty printer *)
+
+open Print
+
+let fTail f xs =
+  let g prf = List.iter (fun x -> prf "; $" [f x]) xs in fExt g
+
+let fList f =
+  function
+      [] -> fStr "[]"
+    | x::xs -> fMeta "[$$]" [f x; fTail(f) xs]
+
+let fName x = fStr x.x_name
+
+let rec fExpr =
+  function
+      Constant n -> 
+        fMeta "Constant_$" [fNum n]
+    | Variable x -> 
+        fMeta "Variable_\"$\"" [fName x]
+    | Monop (w, e1) -> 
+        fMeta "Monop_($, $)" [fStr (Keiko.op_name w); fExpr e1]
+    | Binop (w, e1, e2) -> 
+        fMeta "Binop_($, $, $)" [fStr (Keiko.op_name w); fExpr e1; fExpr e2]
+
+let rec fStmt =
+  function
+      Skip -> 
+        fStr "Skip"
+    | Seq ss -> 
+        fMeta "Seq_$" [fList(fStmt) ss]
+    | Assign (x, e) -> 
+        fMeta "Assign_(\"$\", $)" [fName x; fExpr e]
+    | Print e -> 
+        fMeta "Print_($)" [fExpr e]
+    | Newline -> 
+        fStr "Newline"
+    | IfStmt (e, s1, s2) ->
+        fMeta "IfStmt_($, $, $)" [fExpr e; fStmt s1; fStmt s2]
+    | WhileStmt (e, s) -> 
+        fMeta "WhileStmt_($, $)" [fExpr e; fStmt s]
+(*
+    | RepeatStmt (s, e) ->
+        fMeta "RepeatStmt_($, $)" [fStmt s; fExpr e]
+    | LoopStmt s ->
+        fMeta "LoopStmt_($)" [fStmt s]
+    | ExitStmt ->
+        fStr "Exit"
+    | CaseStmt (e, cases, elsept) ->
+        let fArm (labs, body) = 
+          fMeta "($, $)" [fList(fNum) labs; fStmt body] in
+        fMeta "CaseStmt_($, $, $)" 
+          [fExpr e; fList(fArm) cases; fStmt elsept]
+*)
+    | _ ->
+        (* Catch-all for statements added later *)
+        fStr "???"
+
+let print_tree fp (Program s) = fgrindf fp "" "$" [fStmt s]
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab1/tree.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,37 @@
+(* lab1/tree.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+type ident = string
+
+(* |name| -- type for applied occurrences, with annotations *)
+type name = 
+  { x_name: ident;              (* Name of the reference *)
+    x_lab: string;              (* Global label *)
+    x_line: int }               (* Line number *)
+
+val make_name : ident -> int -> name
+
+
+(* Abstract syntax *)
+
+type program = Program of stmt
+
+and stmt = 
+    Skip 
+  | Seq of stmt list
+  | Assign of name * expr
+  | Print of expr
+  | Newline
+  | IfStmt of expr * stmt * stmt
+  | WhileStmt of expr * stmt
+
+and expr = 
+    Constant of int 
+  | Variable of name
+  | Monop of Keiko.op * expr 
+  | Binop of Keiko.op * expr * expr
+
+(* seq -- neatly join a list of statements into a sequence *)
+val seq : stmt list -> stmt
+
+val print_tree : out_channel -> program -> unit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/Makefile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,83 @@
+# lab2/Makefile
+
+## Add your own test cases to this list
+TEST = gcd array pascal binary
+
+all: ppc
+
+ppc: keiko.cmo lexer.cmo dict.cmo tree.cmo parser.cmo check.cmo \
+		peepopt.cmo kgen.cmo main.cmo
+	ocamlc ../lib/common.cma $^ -o $@
+
+parser.mli parser.ml: parser.mly
+	ocamlyacc parser.mly
+
+lexer.ml: lexer.mll
+	ocamllex lexer.mll
+
+KEIKO = ../keiko
+
+test: force
+	$(MAKE) $(TEST:%=test-%)
+
+test-%: force
+	@echo "*** Test $*.p"
+	./ppc $*.p >a.k
+	$(KEIKO)/pplink -nostdlib $(KEIKO)/lib.k a.k -o a.x >/dev/null
+	-$(KEIKO)/ppx ./a.x >a.test 2>&1
+	sed -n -e '1,/^(\*<</d' -e '/^>>\*)/q' -e p $*.p | diff - a.test
+	@echo "*** Passed"; echo
+
+realclean: clean
+
+clean: force
+	rm -f ppc ppx ppxj *.cma *.cmo *.cmi *.o
+	rm -f parser.mli parser.ml lexer.ml 
+	rm -f a.k a.out a.x a.test
+
+ML = check.ml check.mli dict.ml dict.mli keiko.ml keiko.mli kgen.ml \
+	kgen.mli lexer.ml lexer.mli main.ml parser.ml \
+	parser.mli tree.ml tree.mli peepopt.mli peepopt.ml
+
+depend : $(ML) force
+	(sed '/^###/q' Makefile; echo; ocamldep $(ML)) >new
+	mv new Makefile
+
+%.cmi : %.mli
+	ocamlc $(MLFLAGS) -c $<
+
+%.cmo : %.ml
+	ocamlc $(MLFLAGS) -c $<
+
+force:
+
+MLFLAGS = -I ../lib
+
+###
+
+check.cmo : tree.cmi keiko.cmi dict.cmi check.cmi
+check.cmx : tree.cmx keiko.cmx dict.cmx check.cmi
+check.cmi : tree.cmi
+dict.cmo : dict.cmi
+dict.cmx : dict.cmi
+dict.cmi :
+keiko.cmo : tree.cmi keiko.cmi
+keiko.cmx : tree.cmx keiko.cmi
+keiko.cmi :
+kgen.cmo : tree.cmi peepopt.cmi keiko.cmi dict.cmi kgen.cmi
+kgen.cmx : tree.cmx peepopt.cmx keiko.cmx dict.cmx kgen.cmi
+kgen.cmi : tree.cmi
+lexer.cmo : tree.cmi parser.cmi keiko.cmi lexer.cmi
+lexer.cmx : tree.cmx parser.cmx keiko.cmx lexer.cmi
+lexer.cmi : parser.cmi
+main.cmo : tree.cmi parser.cmi lexer.cmi kgen.cmi dict.cmi check.cmi
+main.cmx : tree.cmx parser.cmx lexer.cmx kgen.cmx dict.cmx check.cmx
+parser.cmo : tree.cmi lexer.cmi keiko.cmi dict.cmi parser.cmi
+parser.cmx : tree.cmx lexer.cmx keiko.cmx dict.cmx parser.cmi
+parser.cmi : tree.cmi keiko.cmi dict.cmi
+peepopt.cmo : keiko.cmi peepopt.cmi
+peepopt.cmx : keiko.cmx peepopt.cmi
+peepopt.cmi : keiko.cmi
+tree.cmo : keiko.cmi dict.cmi tree.cmi
+tree.cmx : keiko.cmx dict.cmx tree.cmi
+tree.cmi : keiko.cmi dict.cmi
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/array.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,30 @@
+(* lab2/array.p *)
+
+var a: array 10 of integer;
+var i: integer;
+
+begin
+  i := 2; a[0] := 1; a[1] := 1;
+  while i < 10 do
+    a[i] := a[i-2] + a[i-1];
+    i := i+1
+  end;
+  i := 0;
+  while i < 10 do
+    print a[i]; newline;
+    i := i+1;
+  end
+end.
+
+(*<<
+ 1
+ 1
+ 2
+ 3
+ 5
+ 8
+ 13
+ 21
+ 34
+ 55
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/binary.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,26 @@
+var n, v, w, k: integer; 
+var d: array 32 of boolean;
+
+begin
+  v := 31415926;
+
+  k := 0;
+  while v <> 0 do
+    d[k] := (v mod 2) <> 0;
+    v := v div 2;
+    k := k+1
+  end;
+
+  w := 0;
+  while k > 0 do
+    k := k-1;
+    w := 2*w;
+    if d[k] then w := w+1 end
+  end;
+
+  print w; newline
+end.
+
+(*<<
+ 31415926
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/check.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,132 @@
+(* lab2/check.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Print 
+open Keiko
+open Tree 
+open Dict 
+
+(* |err_line| -- line number for error messages *)
+let err_line = ref 1
+
+(* |Semantic_error| -- exception raised if error detected *)
+exception Semantic_error of string * Print.arg list * int
+
+(* |sem_error| -- issue error message by raising exception *)
+let sem_error fmt args = 
+  raise (Semantic_error (fmt, args, !err_line))
+
+(* |accum| -- fold_left with arguments swapped *)
+let rec accum f xs a =
+  match xs with
+      [] -> a
+    | y::ys -> accum f ys (f y a)
+
+(* |lookup_def| -- find definition of a name, give error is none *)
+let lookup_def x env =
+  err_line := x.x_line;
+  try let d = lookup x.x_name env in x.x_def <- Some d; d.d_type with 
+    Not_found -> sem_error "$ is not declared" [fStr x.x_name]
+
+(* |add_def| -- add definition to env, give error if already declared *)
+let add_def d env =
+  try define d env with 
+    Exit -> sem_error "$ is already declared" [fStr d.d_tag]
+
+(* |type_error| -- report a type error.  The message could be better. *)
+let type_error () = sem_error "type mismatch in expression" []
+
+(* |check_monop| -- check a unary operator and return its type *)
+let check_monop w t =
+  match w with
+      Uminus ->
+        if t <> Integer then type_error ();
+        Integer
+    | Not ->
+        if t <> Boolean then type_error ();
+        Boolean
+    | _ -> failwith "bad monop"
+
+(* |check_binop| -- check a binary operator and return its type *)
+let check_binop w ta tb =
+  match w with
+      Plus | Minus | Times | Div | Mod ->
+        if ta <> Integer || tb <> Integer then type_error ();
+        Integer
+    | Eq | Lt | Gt | Leq | Geq | Neq ->
+        if ta <> tb then type_error ();
+        Boolean
+    | And | Or ->
+        if ta <> Boolean || tb <> Boolean then type_error ();
+        Boolean
+    | _ -> failwith "bad binop"
+
+(* |check_expr| -- check and annotate an expression *)
+let rec check_expr e env =
+  let t = expr_type e env in
+  (e.e_type <- t; t)
+
+(* |expr_type| -- check an expression and return its type *)
+and expr_type e env = 
+  match e.e_guts with
+      Variable x -> 
+        lookup_def x env
+    | Sub (v, e) ->
+        failwith "subscripts not implemented"
+    | Constant (n, t) -> t
+    | Monop (w, e1) -> 
+        let t = check_expr e1 env in
+        check_monop w t
+    | Binop (w, e1, e2) -> 
+        let ta = check_expr e1 env
+        and tb = check_expr e2 env in
+        check_binop w ta tb
+
+(* |check_stmt| -- check and annotate a statement *)
+let rec check_stmt s env =
+  match s with
+      Skip -> ()
+    | Seq ss ->
+        List.iter (fun s1 -> check_stmt s1 env) ss
+    | Assign (lhs, rhs) ->
+        let ta = check_expr lhs env
+        and tb = check_expr rhs env in
+        if ta <> tb then sem_error "type mismatch in assignment" []
+    | Print e ->
+        let t = check_expr e env in
+        if t <> Integer then sem_error "print needs an integer" []
+    | Newline ->
+        ()
+    | IfStmt (cond, thenpt, elsept) ->
+        let t = check_expr cond env in
+        if t <> Boolean then
+          sem_error "boolean needed in if statement" [];
+        check_stmt thenpt env; 
+        check_stmt elsept env
+    | WhileStmt (cond, body) ->
+        let t = check_expr cond env in
+        if t <> Boolean then
+          sem_error "need boolean after while" [];
+        check_stmt body env
+
+(* |make_def| -- construct definition of variable *)
+let make_def x t a = { d_tag = x; d_type = t; d_lab = a }
+
+(* |check_decl| -- check declaration and return extended environment *)
+let check_decl (Decl (vs, t)) env0 =
+  let declare x env = 
+    let lab = sprintf "_$" [fStr x.x_name] in
+    let d = make_def x.x_name t lab in
+    x.x_def <- Some d; add_def d env in
+  accum declare vs env0
+
+(* |check_decls| -- check a sequence of declarations *)
+let check_decls ds env0 =
+  accum check_decl ds env0
+
+(* |annotate| -- check and annotate a program *)
+let annotate (Program (ds, ss)) =
+  let env = check_decls ds init_env in
+  check_stmt ss env
+
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/check.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,23 @@
+(* lab2/check.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* 
+This module is the semantic analysis pass of the compiler.  It
+provides a single function |annotate| that takes a program, checks it
+for semantic errors, and annotates each applied occurrence of an
+identifier with the corresponding definition.  These annotations are
+used by the code generation pass to generate code for variable
+references.
+
+If a semantic error is detected, |annotate| raises the exception
+|Semantic_error|.  Its arguments are a line number and a format and
+argument list that can be passed to printf to print the message.
+Because there is no way of resuming the analysis, only one error can
+be detected per run of the compiler.
+*)
+
+(* |annotate| -- check tree for type errors and annotate with definitions *)
+val annotate : Tree.program -> unit
+
+(* |Semantic_error| -- exception raised if error detected *)
+exception Semantic_error of string * Print.arg list * int
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/compile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,13 @@
+#!/bin/sh
+
+# This hacked up version works, at least on Linux, even for people who
+# have spaces in the names of directories.  Sheesh.
+
+KEIKO=`cd ../keiko; pwd`
+
+set -x
+
+./ppc $* >a.k \
+    && "$KEIKO/pplink" -nostdlib -i "/usr/bin/env $KEIKO/ppx" \
+        "$KEIKO/lib.k" a.k -o a.out >/dev/null \
+    && chmod +x a.out
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/dict.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,36 @@
+(* lab2/dict.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* Environments are implemented using a library module that 
+   represents mappings by balanced binary trees. *)
+
+type ident = string
+
+type ptype = 
+    Integer 
+  | Boolean 
+  | Array of int * ptype
+  | Void
+
+(* |def| -- definitions in environment *)
+type def = 
+  { d_tag: ident;               (* Name *)
+    d_type: ptype;              (* Type *)
+    d_lab: string }             (* Global label *)
+
+module IdMap = Map.Make(struct type t = ident  let compare = compare end)
+
+type environment = Env of def IdMap.t
+
+let can f x = try f x; true with Not_found -> false
+
+(* |define| -- add a definition *)
+let define d (Env e) = 
+  if can (IdMap.find d.d_tag) e then raise Exit;
+  Env (IdMap.add d.d_tag d e)
+
+(* |lookup| -- find definition of an identifier *)
+let lookup x (Env e) = IdMap.find x e
+
+(* |init_env| -- empty environment *)
+let init_env = Env IdMap.empty
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/dict.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,27 @@
+(* lab2/dict.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+type ident = string
+
+type ptype = 
+    Integer 
+  | Boolean 
+  | Array of int * ptype
+  | Void
+
+(* |def| -- definitions in environment *)
+type def = 
+  { d_tag: ident;               (* Name *)
+    d_type: ptype;              (* Type *)
+    d_lab: string }             (* Global label *)
+
+type environment
+
+(* |define| -- add a definition, raise Exit if already declared *)
+val define : def -> environment -> environment
+
+(* |lookup| -- search an environment or raise Not_found *)
+val lookup : ident -> environment -> def
+
+(* |init_env| -- initial empty environment *)
+val init_env : environment
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/gcd.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,19 @@
+(* lab2/gcd.p *)
+
+var x, y: integer;
+
+begin
+  x := 3 * 37; y := 5 * 37;
+  while x <> y do
+    if x > y then
+      x := x - y
+    else
+      y := y - x
+    end
+  end;
+  print x; newline
+end.
+
+(*<<
+ 37
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/keiko.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,276 @@
+(* common/keiko.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree 
+open Print
+
+(* |codelab| -- type of code labels *)
+type codelab = int
+
+(* |lastlab| -- last used code label *)
+let lastlab = ref 0
+
+(* |label| -- allocate a code label *)
+let label () = incr lastlab; !lastlab
+
+(* |fLab| -- format a code label for printf *)
+let fLab n = fMeta "L$" [fNum n]
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
+
+(* |code| -- type of intermediate instructions *)
+type code =
+    CONST of int                (* Push constant (value) *)
+  | GLOBAL of string            (* Push global address (name) *)
+  | LOCAL of int                (* Push local adddress (offset) *)
+  | LOADW                       (* Load word *)
+  | STOREW                      (* Store word *)
+  | LOADC                       (* Load character *)
+  | STOREC                      (* Store character *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (op, dest) *)
+  | PCALL of int                (* Call procedure *)
+  | PCALLW of int               (* Proc call with result (nargs) *)
+  | RETURNW                     (* Return from procedure *)
+  | BOUND of int                (* Bounds check *)
+  | CASEJUMP of int             (* Case jump (num cases) *)
+  | CASEARM of int * codelab    (* Case value and label *)
+  | PACK                        (* Pack two values into one *)
+  | UNPACK                      (* Unpack one value into two *)
+  | DUP
+  | POP
+
+  | LDGW of string              (* Load Global Word (name) *)
+  | STGW of string              (* Store Global Word (name) *)
+  | LDLW of int                 (* Load Local Word (offset) *)
+  | STLW of int                 (* Store Local Word (offset) *)
+  | LDNW of int                 (* Load word with offset *)
+  | STNW of int                 (* Store word with offset *)
+
+  | LINE of int
+  | SEQ of code list
+  | NOP
+
+(* op_name -- map an operator to its name *)
+let op_name =
+  function
+      Plus -> "Plus" | Minus -> "Minus" | Times -> "Times"
+    | Div -> "Div" | Mod -> "Mod" | Eq -> "Eq"
+    | Uminus -> "Uminus" | Lt -> "Lt" | Gt -> "Gt" 
+    | Leq -> "Leq" | Geq -> "Geq" | Neq -> "Neq" 
+    | And -> "And" | Or -> "Or" | Not -> "Not"
+
+(* fOp -- format an operator as an instruction *)
+let fOp w =
+  (* Avoid the deprecated String.uppercase *)
+  let upc ch =
+    if ch >= 'a' && ch <= 'z' then Char.chr (Char.code ch - 32) else ch in
+  fStr (String.map upc (op_name w))
+
+(* |fInst| -- format an instruction for |printf| *)
+let fInst =
+  function
+      CONST x ->        fMeta "CONST $" [fNum x]
+    | GLOBAL a ->       fMeta "GLOBAL $" [fStr a]
+    | LOCAL n ->        fMeta "LOCAL $" [fNum n]
+    | LOADW ->          fStr "LOADW"
+    | STOREW ->         fStr "STOREW"
+    | LOADC ->          fStr "LOADC"
+    | STOREC ->         fStr "STOREC"
+    | MONOP w ->        fOp w
+    | BINOP w ->        fOp w
+    | OFFSET ->         fStr "OFFSET"
+    | LABEL l ->        fMeta "LABEL $" [fLab l]
+    | JUMP l ->         fMeta "JUMP $" [fLab l]
+    | JUMPC (w, l) ->   fMeta "J$ $" [fOp w; fLab l]
+    | PCALL n ->        fMeta "PCALL $" [fNum n]
+    | PCALLW n ->       fMeta "PCALLW $" [fNum n]
+    | RETURNW ->        fStr "RETURNW"
+    | BOUND n ->        fMeta "BOUND $" [fNum n]
+    | CASEJUMP n ->     fMeta "CASEJUMP $" [fNum n]
+    | CASEARM (v, l) -> fMeta "CASEARM $ $" [fNum v; fLab l]
+    | PACK ->           fStr "PACK"
+    | UNPACK ->         fStr "UNPACK"
+    | DUP ->            fStr "DUP 0"
+    | POP ->            fStr "POP 1"
+    | LDGW a ->         fMeta "LDGW $" [fStr a]
+    | STGW a ->         fMeta "STGW $" [fStr a]
+    | LDLW n ->         fMeta "LDLW $" [fNum n]
+    | STLW n ->         fMeta "STLW $" [fNum n]
+    | LDNW n ->         fMeta "LDNW $" [fNum n]
+    | STNW n ->         fMeta "STNW $" [fNum n]
+    | LINE n ->         fMeta "LINE $" [fNum n]
+    | SEQ _ ->          fStr "SEQ ..."
+    | NOP ->            fStr "NOP"
+
+let mark_line n ys =
+  if n = 0 then ys else
+    match ys with
+        [] | LINE _ :: _ -> ys
+      | _ -> LINE n :: ys
+
+(* |canon| -- flatten a code sequence *)
+let canon x =
+  let rec accum x ys =
+    match x with
+        SEQ xs -> List.fold_right accum xs ys
+      | NOP -> ys
+      | LINE n -> 
+          if n = 0 then 
+            ys 
+          else begin
+            match ys with
+                [] -> ys
+              | LINE _ :: _ -> ys
+              | _ -> LINE n :: ys
+          end
+      | _ -> x :: ys in
+  SEQ (accum x [])
+
+
+(* SANITY CHECKS *)
+
+(* The checks implemented here ensure that the value stack is used in a 
+   consistent way, and that CASEJUMP instructions are followed by the 
+   correct number of case labels.  There are a few assumptions, the main
+   one being that backwards jumps leave nothing on the stack. *)
+
+(* Compute pair (a, b) if an instruction pops a values and pushes b *)
+let delta =
+  function
+      CONST _ | GLOBAL _ | LOCAL _ | LDGW _ | LDLW _ -> (0, 1)
+    | STGW _ | STLW _ -> (1, 0)
+    | LOADW | LOADC | LDNW _ -> (1, 1)
+    | STOREW | STOREC | STNW _ -> (2, 0)
+    | MONOP _ -> (1, 1)
+    | BINOP _ | OFFSET -> (2, 1)
+    | PCALL n -> (n+2, 0)
+    | PCALLW n -> (n+2, 1)
+    | RETURNW -> (1, 0)
+    | BOUND _ -> (2, 1)
+    | PACK -> (2, 1)
+    | UNPACK -> (1, 2)
+    | LINE _ -> (0, 0)
+    | DUP -> (1, 2)
+    | POP -> (1, 0)
+    | i -> failwith (sprintf "delta $" [fInst i])
+
+(* Output code and check for basic sanity *)
+let check_and_output code =
+  let line = ref 0 in
+
+  (* Output an instruction *)
+  let out =
+    function 
+        LINE n -> 
+          if n <> 0 && !line <> n then begin
+            printf "! $\n" [fStr (Source.get_line n)];
+            line := n
+          end
+      | x -> printf "$\n" [fInst x] in
+
+  (* Report failure of sanity checks *)
+  let insane fmt args =
+    fprintf stderr "WARNING: Code failed sanity checks -- $\n" [fMeta fmt args];
+    printf "! *** HERE!\n" [];
+    raise Exit in
+
+  (* Map labels to (depth, flag) pairs *)
+  let labdict = Hashtbl.create 50 in
+
+  (* Note the depth at a label and check for consistency *)
+  let note_label lab def d =
+    try 
+      let (d1, f) = Hashtbl.find labdict lab in
+      if d >= 0 && d <> d1 then
+        insane "inconsistent stack depth ($ <> $) at label $" 
+          [fNum d; fNum d1; fNum lab];
+      if def then begin
+        if !f then insane "multiply defined label $" [fNum lab];
+        f := true
+      end;
+      d1
+    with Not_found ->
+      (* If this point is after an unconditional jump (d < 0) and 
+         the label is not defined previously, assume depth 0 *)
+      let d1 = max d 0 in
+      Hashtbl.add labdict lab (d1, ref def);
+      d1 in
+
+  (* Check all mentioned labels have been defined *)
+  let check_labs () =
+    Hashtbl.iter (fun lab (d, f) -> 
+      if not !f then insane "label $ is not defined" [fNum lab]) labdict in
+
+  let tail = ref [] in
+
+  let output () = out (List.hd !tail); tail := List.tl !tail in
+
+  (* Scan an instruction sequence, keeping track of the stack depth *)
+  let rec scan d = 
+    match !tail with
+        [] -> 
+          if d <> 0 then insane "stack not empty at end" []
+      | x :: _ ->
+          let need a =
+            if d < a then 
+              insane "stack underflow at instruction $" [fInst x] in
+          output ();
+          begin match x with
+              LABEL lab -> 
+                scan (note_label lab true d)
+            | JUMP lab -> 
+                unreachable (note_label lab false d)
+            | JUMPC (_, lab) -> 
+                need 2; scan (note_label lab false (d-2))
+            | CASEARM (_, _) -> 
+                insane "unexpected CASEARM" []
+            | CASEJUMP n -> 
+                need 1; jumptab n (d-1)
+            | SEQ _ | NOP -> 
+                failwith "sanity2"
+            | _ -> 
+                let (a, b) = delta x in need a; scan (d-a+b)
+          end
+
+  (* Scan a jump table, checking for the correct number of entries *)
+  and jumptab n d =
+    match !tail with
+        CASEARM (_, lab) :: _ -> 
+          output ();
+          if n = 0 then
+            insane "too many CASEARMs after CASEJUMP" [];
+          jumptab (n-1) (note_label lab false d)
+      | _ -> 
+          if n > 0 then
+            insane "too few CASEARMs after CASEJUMP" [];
+          scan d
+
+  (* Scan code after an unconditional jump *)
+  and unreachable d =
+    match !tail with
+        [] -> ()
+      | LABEL lab :: _ ->
+          output ();
+          scan (note_label lab true (-1))
+      | _ -> 
+          (* Genuinely unreachable code -- assume stack is empty *)
+          scan 0 in
+
+  match canon code with
+      SEQ xs -> 
+        tail := xs; 
+        (try scan 0; check_labs () with Exit -> 
+          (* After error, output rest of code without checks *)
+          List.iter out !tail; exit 1)
+    | _ -> failwith "sanity"
+
+let output code = 
+  try check_and_output code with Exit -> exit 1
+    
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/keiko.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,61 @@
+(* common/keiko.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |codelab| -- type of code labels *)
+type codelab = int
+
+(* |label| -- allocate a code label *)
+val label : unit -> codelab
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
+
+(* op_name -- map an operator to its name *)
+val op_name : op -> string
+
+(* |code| -- type of intermediate instructions *)
+type code =
+    CONST of int                (* Push constant (value) *)
+  | GLOBAL of string            (* Push global address (name) *)
+  | LOCAL of int                (* Push local adddress (offset) *)
+  | LOADW                       (* Load word *)
+  | STOREW                      (* Store word *)
+  | LOADC                       (* Load character *)
+  | STOREC                      (* Store character *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (op, dest) *)
+  | PCALL of int                (* Call procedure *)
+  | PCALLW of int               (* Proc call with result (nargs) *)
+  | RETURNW                     (* Return from procedure *)
+  | BOUND of int                (* Bounds check *)
+  | CASEJUMP of int             (* Case jump (num cases) *)
+  | CASEARM of int * codelab    (* Case value and label *)
+  | PACK                        (* Pack two values into one *)
+  | UNPACK                      (* Unpack one value into two *)
+  | DUP
+  | POP
+
+  | LDGW of string              (* Load Global Word (name) *)
+  | STGW of string              (* Store Global Word (name) *)
+  | LDLW of int                 (* Load Local Word (offset) *)
+  | STLW of int                 (* Store Local Word (offset) *)
+  | LDNW of int                 (* Load word with offset *)
+  | STNW of int                 (* Store word with offset *)
+
+  | LINE of int
+  | SEQ of code list
+  | NOP
+
+(* |fInst| -- format an instruction for |printf| *)
+val fInst : code -> Print.arg
+
+(* |canon| -- flatten a code sequence *)
+val canon : code -> code
+
+(* |output| -- output a code sequence *)
+val output : code -> unit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/kgen.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,93 @@
+(* lab2/kgen.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Dict 
+open Tree 
+open Keiko 
+open Print
+
+let optflag = ref false
+
+(* |line_number| -- find line number of variable reference *)
+let rec line_number e =
+  match e.e_guts with
+      Variable x -> x.x_line
+    | Sub (a, e) -> line_number a
+    | _ -> 999
+
+(* |gen_expr| -- generate code for an expression *)
+let rec gen_expr e =
+  match e.e_guts with
+      Variable _ | Sub _ ->
+        SEQ [gen_addr e; LOADW]
+    | Constant (n, t) ->
+        CONST n
+    | Monop (w, e1) ->
+        SEQ [gen_expr e1; MONOP w]
+    | Binop (w, e1, e2) ->
+        SEQ [gen_expr e1; gen_expr e2; BINOP w]
+
+(* |gen_addr| -- generate code to push address of a variable *)
+and gen_addr v =
+  match v.e_guts with
+      Variable x ->
+        let d = get_def x in
+        SEQ [LINE x.x_line; GLOBAL d.d_lab]
+    | _ ->
+        failwith "gen_addr"
+
+(* |gen_cond| -- generate code for short-circuit condition *)
+let rec gen_cond e tlab flab =
+  (* Jump to |tlab| if |e| is true and |flab| if it is false *)
+  match e.e_guts with
+      Constant (x, t) ->
+        if x <> 0 then JUMP tlab else JUMP flab
+    | Binop ((Eq|Neq|Lt|Gt|Leq|Geq) as w, e1, e2) ->
+        SEQ [gen_expr e1; gen_expr e2;
+          JUMPC (w, tlab); JUMP flab]
+    | Monop (Not, e1) ->
+        gen_cond e1 flab tlab
+    | Binop (And, e1, e2) ->
+        let lab1 = label () in
+        SEQ [gen_cond e1 lab1 flab; LABEL lab1; gen_cond e2 tlab flab]
+    | Binop (Or, e1, e2) ->
+        let lab1 = label () in
+        SEQ [gen_cond e1 tlab lab1; LABEL lab1; gen_cond e2 tlab flab]
+    | _ ->
+        SEQ [gen_expr e; CONST 0; JUMPC (Neq, tlab); JUMP flab]
+
+(* |gen_stmt| -- generate code for a statement *)
+let rec gen_stmt =
+  function
+      Skip -> NOP
+    | Seq stmts -> SEQ (List.map gen_stmt stmts)
+    | Assign (v, e) ->
+        SEQ [LINE (line_number v); gen_expr e; gen_addr v; STOREW]
+    | Print e ->
+        SEQ [gen_expr e; CONST 0; GLOBAL "lib.print"; PCALL 1]
+    | Newline ->
+        SEQ [CONST 0; GLOBAL "lib.newline"; PCALL 0]
+    | IfStmt (test, thenpt, elsept) ->
+        let lab1 = label () and lab2 = label () and lab3 = label () in
+        SEQ [gen_cond test lab1 lab2; 
+          LABEL lab1; gen_stmt thenpt; JUMP lab3;
+          LABEL lab2; gen_stmt elsept; LABEL lab3]
+    | WhileStmt (test, body) ->
+        let lab1 = label () and lab2 = label () and lab3 = label () in
+        SEQ [JUMP lab2; LABEL lab1; gen_stmt body; 
+          LABEL lab2; gen_cond test lab1 lab3; LABEL lab3]
+
+let gen_decl (Decl (xs, t)) =
+  List.iter (fun x ->
+      let d = get_def x in
+      let s = 4 in
+      printf "GLOVAR $ $\n" [fStr d.d_lab; fNum s]) xs
+
+(* |translate| -- generate code for the whole program *)
+let translate (Program (ds, ss)) = 
+  let code = gen_stmt ss in
+  printf "PROC MAIN 0 0 0\n" [];
+  Keiko.output (if !optflag then Peepopt.optimise code else code);
+  printf "RETURN\n" [];
+  printf "END\n\n" [];
+  List.iter gen_decl ds
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/kgen.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,12 @@
+(* lab2/kgen.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* The intermediate code generator takes an abstract syntax tree that
+   has been annotated by the semantic analyser, and produces abstract
+   machine code.  No errors should be detected in this part if the
+   compiler, unless earlier passes are broken. *)
+
+(* |translate| -- generate intermediate code *)
+val translate : Tree.program -> unit
+
+val optflag : bool ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/lexer.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,15 @@
+(* lab2/lexer.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(*
+The lexer is generated from a camllex script.  It takes an input
+buffer, reads a token, and returns the |token| value that corresponds
+to it.  The lexer maintains the current line number in |lineno| for
+producing error messages.
+*)
+
+(* |token| -- scan a token and return its code *)
+val token : Lexing.lexbuf -> Parser.token
+
+(* |lineno| -- number of current line *)
+val lineno : int ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/lexer.mll	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,68 @@
+(* lab2/lexer.mll *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+{
+open Keiko
+open Parser 
+open Tree 
+open Lexing 
+
+let lineno = ref 1
+
+let make_hash n ps =
+  let t = Hashtbl.create n in
+  List.iter (fun (k, v) -> Hashtbl.add t k v) ps;
+  t
+
+(* A little table to recognize keywords *)
+let kwtable = 
+  make_hash 64
+    [ ("begin", BEGIN); ("do", DO); ("if", IF ); ("else", ELSE); 
+      ("end", END); ("then", THEN);
+      ("var", VAR); ("while", WHILE); ("print", PRINT); ("newline", NEWLINE);
+      ("integer", INTEGER); ("boolean", BOOLEAN); ("array", ARRAY); 
+      ("of", OF); ("true", BOOLCONST 1); ("false",  BOOLCONST 0);
+      ("and", MULOP And); ("div", MULOP Div); ("or", ADDOP Or);
+      ("not", MONOP Not); ("mod", MULOP Mod) ]
+
+let lookup s = 
+  try Hashtbl.find kwtable s with Not_found -> IDENT s
+}
+
+rule token = 
+  parse
+      ['A'-'Z''a'-'z']['A'-'Z''a'-'z''0'-'9''_']* as s
+                        { lookup s }
+    | ['0'-'9']+ as s   { NUMBER (int_of_string s) }
+    | ";"               { SEMI }
+    | "."               { DOT }
+    | ":"               { COLON }
+    | "("               { LPAR }
+    | ")"               { RPAR }
+    | "["               { SUB }
+    | "]"               { BUS }
+    | ","               { COMMA }
+    | "="               { EQUAL }
+    | "+"               { ADDOP Plus }
+    | "-"               { MINUS }
+    | "*"               { MULOP Times }
+    | "<"               { RELOP Lt }
+    | ">"               { RELOP Gt }
+    | "<>"              { RELOP Neq }
+    | "<="              { RELOP Leq }
+    | ">="              { RELOP Geq }
+    | ":="              { ASSIGN }
+    | [' ''\t']+        { token lexbuf }
+    | "(*"              { comment lexbuf; token lexbuf }
+    | "\n"              { incr lineno; Source.note_line !lineno lexbuf;
+                          token lexbuf }
+    | _                 { BADTOK }
+    | eof               { EOF }
+
+and comment = parse
+      "*)"              { () }
+    | "\n"              { incr lineno; Source.note_line !lineno lexbuf;
+                          comment lexbuf }
+    | _                 { comment lexbuf }
+    | eof               { () }
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/main.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,45 @@
+(* lab2/main.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Print
+open Dict
+open Source
+
+(* |main| -- main program *)
+let main () =
+  let dflag = ref false in
+  let fns = ref [] in
+  let usage =  "Usage: ppc [-d] file.p" in
+  Arg.parse [("-d", Arg.Set dflag, " Print the tree");
+      ("-O", Arg.Unit (fun () -> Kgen.optflag := true), " Peephole optimiser")]
+    (function s -> fns := !fns @ [s]) usage;
+  if List.length !fns <> 1 then begin 
+    fprintf stderr "$\n" [fStr usage]; exit 2 
+  end;
+  let in_file = List.hd !fns in
+  let in_chan = open_in in_file in
+  Source.init in_file in_chan;
+  let lexbuf = Lexing.from_channel in_chan in
+  let prog = try Parser.program Lexer.token lexbuf with
+      Parsing.Parse_error ->
+        let tok = Lexing.lexeme lexbuf in
+        err_message "syntax error at token '$'" 
+          [fStr tok] !Lexer.lineno;
+        exit 1 in
+
+  if !dflag then Tree.print_tree stdout prog;
+
+  begin 
+    try Check.annotate prog with
+      Check.Semantic_error (fmt, args, line) ->
+        err_message fmt args line;
+        exit 1
+  end;
+
+  printf "MODULE Main 0 0\n" [];
+  printf "IMPORT Lib 0\n" [];
+  printf "ENDHDR\n\n" [];
+  Kgen.translate prog;
+  exit 0
+
+let ppc = main ()
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/parser.mly	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,93 @@
+/* lab2/parser.mly */
+/* Copyright (c) 2017 J. M. Spivey */
+
+%{
+open Keiko
+open Dict 
+open Tree
+%}
+
+%token <Dict.ident>     IDENT
+%token <Keiko.op>       MULOP ADDOP RELOP MONOP
+%token <int>            NUMBER BOOLCONST
+
+/* punctuation */
+%token                  SEMI DOT COLON LPAR RPAR COMMA
+%token                  EQUAL MINUS ASSIGN EOF BADTOK
+%token                  SUB BUS
+
+/* keywords */
+%token                  BEGIN DO ELSE END IF 
+%token                  THEN VAR WHILE PRINT NEWLINE
+%token                  ARRAY OF
+%token                  INTEGER BOOLEAN
+
+%type <Tree.program>    program
+
+%start                  program
+
+%%
+
+program :       
+    decls BEGIN stmts END DOT           { Program ($1, $3) } ;
+
+decls : 
+    /* empty */                         { [] }
+  | decl decls                          { $1 :: $2 }
+
+decl :
+    VAR name_list COLON typexp SEMI     { Decl ($2, $4) } ;
+
+name_list :     
+    name                                { [$1] }
+  | name COMMA name_list                { $1 :: $3 } ;
+
+typexp :
+    INTEGER                             { Integer }
+  | BOOLEAN                             { Boolean } 
+  | ARRAY NUMBER OF typexp              { Array ($2, $4) } ;
+
+stmts : 
+    stmt_list                           { seq $1 } ;
+
+stmt_list :
+    stmt                                { [$1] }
+  | stmt SEMI stmt_list                 { $1 :: $3 } ;
+
+stmt :  
+    /* empty */                         { Skip }
+  | variable ASSIGN expr                { Assign ($1, $3) }
+  | PRINT expr                          { Print $2 }
+  | NEWLINE                             { Newline }
+  | IF expr THEN stmts END              { IfStmt ($2, $4, Skip) }
+  | IF expr THEN stmts ELSE stmts END   { IfStmt ($2, $4, $6) }
+  | WHILE expr DO stmts END             { WhileStmt ($2, $4) } ;
+
+expr :
+    simple                              { $1 }
+  | expr RELOP simple                   { makeExpr (Binop ($2, $1, $3)) }
+  | expr EQUAL simple                   { makeExpr (Binop (Eq, $1, $3)) } ;
+
+simple :
+    term                                { $1 }
+  | simple ADDOP term                   { makeExpr (Binop ($2, $1, $3)) }
+  | simple MINUS term                   { makeExpr (Binop (Minus, $1, $3)) } ;
+
+term :
+    factor                              { $1 }
+  | term MULOP factor                   { makeExpr (Binop ($2, $1, $3)) }
+
+factor :
+    variable                            { $1 }
+  | NUMBER                              { makeExpr (Constant ($1, Integer)) }
+  | BOOLCONST                           { makeExpr (Constant ($1, Boolean)) }
+  | MONOP factor                        { makeExpr (Monop ($1, $2)) }
+  | MINUS factor                        { makeExpr (Monop (Uminus, $2)) }
+  | LPAR expr RPAR                      { $2 } ;
+
+variable :
+    name                                { makeExpr (Variable $1) }
+  | variable SUB expr BUS               { makeExpr (Sub ($1, $3)) } ;
+
+name :  
+    IDENT                               { makeName $1 !Lexer.lineno } ;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/pascal.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,27 @@
+(* lab2/pascal.p *)
+
+var a: array 5 of array 5 of integer;
+var i, j: integer;
+
+begin
+  i := 0;
+  while i < 5 do
+    a[i][0] := 1; j := 1;
+    print a[i][0];
+    while j <= i do
+      a[i][j] := a[i-1][j-1] + a[i-1][j];
+      print a[i][j];
+      j := j+1
+    end;
+    newline;
+    i := i+1
+  end 
+end.
+
+(*<<
+ 1
+ 1 1
+ 1 2 1
+ 1 3 3 1
+ 1 4 6 4 1
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/peepopt.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,172 @@
+(* ppc/peepopt.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Keiko
+open Print
+
+let debug = ref 0
+
+(* Disjoint sets of labels *)
+
+type lab_data = 
+    LabDef of labrec                    (* An extant label *)
+  | Equiv of codelab                    (* A label that's been merged *)
+
+and labrec =
+  { y_id: codelab;                      (* Name of the label *)
+    y_refct: int ref }                  (* Reference count *)
+
+(* |label_tab| -- map labels to their equivalents *)
+let label_tab = Hashtbl.create 257
+
+(* |get_label| -- get equivalence cell for a label *)
+let get_label x =
+  try !(Hashtbl.find label_tab x) with
+    Not_found ->
+      let y = LabDef { y_id = x; y_refct = ref 0 } in
+      Hashtbl.add label_tab x (ref y); y
+
+(* |find_label| -- find data about equivalence class of a label *)
+let rec find_label x =
+  match get_label x with
+      LabDef y -> y
+    | Equiv x' -> find_label x'
+
+(* |rename| -- get canonical equivalent of a label *)
+let rename x = let y = find_label x in y.y_id
+
+(* |ref_count| -- get reference count cell for a label *)
+let ref_count x = let y = find_label x in y.y_refct
+
+(* |same_lab| -- test if two labels are equivalent *)
+let same_lab x1 x2 = (rename x1 = rename x2)
+
+(* |equate| -- make two labels equivalent *)
+let equate x1 x2 =
+  let y1 = find_label x1 and y2 = find_label x2 in
+  if y1.y_id = y2.y_id then failwith "equate";
+  y2.y_refct := !(y1.y_refct) + !(y2.y_refct);
+  Hashtbl.find label_tab y1.y_id := Equiv y2.y_id
+
+(* |do_refs| -- call function on refcount of each label in an instruction *)
+let do_refs f =
+  function
+      JUMP x -> f (ref_count x)
+    | JUMPC (w, x) -> f (ref_count x)
+    | CASEARM (n, x) -> f (ref_count x)
+    | _ -> ()
+
+(* |rename_labs| -- replace each label by its equivalent *)
+let rename_labs =
+  function
+      LABEL x -> LABEL (rename x)
+    | JUMP x -> JUMP (rename x)
+    | JUMPC (w, x) -> JUMPC (w, rename x)
+    | CASEARM (n, x) -> CASEARM (n, rename x)
+    | i -> i
+
+let opposite =
+  function Eq -> Neq | Neq -> Eq | Lt  -> Geq
+    | Leq -> Gt | Gt  -> Leq | Geq -> Lt
+    | _ -> failwith "opposite"
+
+(* |ruleset| -- simplify and introduce abbreviations *)
+let ruleset replace =
+  function
+      LOCAL a :: CONST b :: OFFSET :: _ ->
+        replace 3 [LOCAL (a+b)]
+    | CONST a :: OFFSET :: CONST b :: OFFSET :: _ ->
+        replace 4 [CONST (a+b); OFFSET]
+    | CONST 0 :: OFFSET :: _ ->
+        replace 2 []
+     
+    | GLOBAL x :: LOADW :: _ ->
+        replace 2 [LDGW x]
+    | GLOBAL x :: STOREW :: _ ->
+        replace 2 [STGW x]
+    | LOCAL n :: LOADW :: _ ->
+        replace 2 [LDLW n]
+    | LOCAL n :: STOREW :: _ ->
+        replace 2 [STLW n]
+    | CONST n :: OFFSET :: LOADW :: _ ->
+        replace 3 [LDNW n]
+    | CONST n :: OFFSET :: STOREW :: _ ->
+        replace 3 [STNW n]
+
+    | CONST x :: CONST n :: BOUND _ :: _ when x >= 0 && x < n ->
+        replace 3 [CONST x]
+
+    | LINE n :: LABEL a :: _ ->
+        replace 2 [LABEL a; LINE n]
+    | LINE n :: LINE m :: _ ->
+        replace 1 []
+    | LABEL a :: LABEL b :: _ ->
+        equate a b; replace 2 [LABEL a]
+    | LABEL a :: JUMP b :: _ when not (same_lab a b) ->
+        equate a b; replace 2 [JUMP b]
+    | JUMPC (w, a) :: JUMP b :: LABEL c :: _ when same_lab a c ->
+        replace 2 [JUMPC (opposite w, b)]
+    | JUMP a :: LABEL b :: _ when same_lab a b ->
+        replace 1 []
+    | JUMP a :: LABEL b :: _ -> 
+        ()
+    | JUMP a :: _ :: _ ->
+        replace 2 [JUMP a]
+    | LABEL a :: _ when !(ref_count a) = 0 ->
+        replace 1 []
+
+    | _ -> ()
+
+(* |take n [x1; x2; ...] = [x1; x2; ...; xn]| *)
+let rec take n =
+  function
+      [] -> []
+    | x::xs -> if n = 0 then [] else x :: take (n-1) xs
+
+(* |drop n [x1; x2; ...] = [x_{n+1}; x_{n+2}; ...]| *)
+let rec drop n =
+  function
+      [] -> []
+    | x::xs -> if n = 0 then x::xs else drop (n-1) xs
+
+(* |optstep| -- apply rules at one place in the buffer *)
+let optstep rules changed code =
+  let ch = ref true in
+  let replace n c = 
+    changed := true; ch := true;
+  if !debug > 0 then
+      printf "! $ --> $\n" [fList(fInst) (take n !code); fList(fInst) c];
+    List.iter (do_refs decr) (take n !code);
+    List.iter (do_refs incr) c; 
+    code := c @ drop n !code in
+  while !ch do
+    ch := false; rules replace !code
+  done
+
+(* |rewrite| -- iterate over the code and apply rules *)
+let rewrite rules prog =
+  let code1 = ref prog and code2 = ref [] in
+  let changed = ref true in
+  while !changed do
+    changed := false;
+    while !code1 <> [] do
+      optstep rules changed code1;
+      if !code1 <> [] then begin
+        code2 := rename_labs (List.hd !code1) :: !code2;
+        code1 := List.tl !code1
+      end
+    done;
+    code1 := List.rev !code2;
+    code2 := []
+  done;
+  !code1
+
+(* |optimise| -- rewrite list of instructions *)
+let optimise prog =
+  match Keiko.canon prog with
+      SEQ code ->
+        List.iter (do_refs incr) code;
+        let code2 = rewrite ruleset code in
+        Hashtbl.clear label_tab;
+        SEQ code2
+    | _ -> failwith "optimise"
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/peepopt.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,8 @@
+(* ppc/peepopt.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |optimise| -- rewrite list of instructions *)
+val optimise : Keiko.code -> Keiko.code
+
+(* |debug| -- debugging level *)
+val debug: int ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/tree.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,116 @@
+(* lab2/tree.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Dict
+open Print
+
+(* |name| -- type for applied occurrences with annotations *)
+type name = 
+  { x_name: ident;              (* Name of the reference *)
+    x_line: int;                (* Line number *)
+    mutable x_def: def option } (* Definition in scope *)
+
+
+(* Abstract syntax *)
+
+type program = Program of decl list * stmt
+
+and decl = Decl of name list * ptype
+
+and stmt = 
+    Skip 
+  | Seq of stmt list
+  | Assign of expr * expr
+  | Print of expr
+  | Newline
+  | IfStmt of expr * stmt * stmt
+  | WhileStmt of expr * stmt
+
+and expr = 
+  { e_guts: expr_guts;
+    mutable e_type: ptype }
+
+and expr_guts =
+    Constant of int * ptype
+  | Variable of name
+  | Sub of expr * expr
+  | Monop of Keiko.op * expr 
+  | Binop of Keiko.op * expr * expr
+
+let seq =
+  function
+      [] -> Skip                (* Use Skip in place of Seq [] *)
+    | [s] -> s                  (* Don't use a Seq node for one element *)
+    | ss -> Seq ss
+
+let makeName x ln = 
+  { x_name = x; x_line = ln; x_def = None }
+
+let get_def x =
+  match x.x_def with
+      Some d -> d
+    | None -> failwith (sprintf "missing def on $" [fStr x.x_name])
+
+let makeExpr e =
+  { e_guts = e; e_type = Void }
+
+
+(* Pretty printer *)
+
+open Print
+
+let fTail f xs =
+  let g prf = List.iter (fun x -> prf "; $" [f x]) xs in fExt g
+
+let fList f =
+  function
+      [] -> fStr "[]"
+    | x::xs -> fMeta "[$$]" [f x; fTail(f) xs]
+
+let fName x = fMeta "\"$\"" [fStr x.x_name]
+
+let rec fType =
+  function
+      Integer -> fStr "Integer"
+    | Boolean -> fStr "Boolean"
+    | Void -> fStr "Void"
+    | Array (n, t) -> fMeta "Array_($, $)" [fNum n; fType t]
+
+let fDecl (Decl (xs, t)) =
+  fMeta "Decl_($, $)" [fList(fName) xs; fType t]
+
+let rec fExpr e =
+  match e.e_guts with
+      Constant (n, t) ->
+        fMeta "Const_$" [fNum n]
+    | Variable x -> 
+        fMeta "Variable_$" [fName x]
+    | Sub (e1, e2) ->
+        fMeta "Sub_($, $)" [fExpr e1; fExpr e2]
+    | Monop (w, e1) -> 
+        fMeta "Monop_($, $)" [fStr (Keiko.op_name w); fExpr e1]
+    | Binop (w, e1, e2) -> 
+        fMeta "Binop_($, $, $)" 
+          [fStr (Keiko.op_name w); fExpr e1; fExpr e2]
+
+let rec fStmt = 
+  function
+      Skip -> 
+        fStr "Skip"
+    | Seq ss -> 
+        fMeta "Seq_$" [fList(fStmt) ss]
+    | Assign (e1, e2) -> 
+        fMeta "Assign_($, $)" [fExpr e1; fExpr e2]
+    | Print e -> 
+        fMeta "Print_($)" [fExpr e]
+    | Newline -> 
+        fStr "Newline"
+    | IfStmt (e, s1, s2) ->
+        fMeta "IfStmt_($, $, $)" [fExpr e; fStmt s1; fStmt s2]
+    | WhileStmt (e, s) -> 
+        fMeta "WhileStmt_($, $)" [fExpr e; fStmt s]
+
+let fProg (Program (ds, s)) = 
+  fMeta "Program_($, $)" [fList(fDecl) ds; fStmt s]
+
+let print_tree fp t = fgrindf fp "" "$" [fProg t]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab2/tree.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,67 @@
+(* lab2/tree.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Dict
+
+(*
+This module describes the type of abstract syntax trees that is used
+as the main interface between parts of the comipler.  A tree is built
+by the parser, then checked by the semantic analyser, which annotates
+identifiers in the tree with their definitions.  The intermediate code
+generator finally traverses the tree, emitting code for each
+expression or statement.
+
+The module also contains some functions that are used to build the
+tree initially; they construct nodes with default values for the
+annotations.  Proper values are filled in later during semantic
+analysis.
+*)
+
+(* |name| -- type for applied occurrences with annotations *)
+type name = 
+  { x_name: ident;              (* Name of the reference *)
+    x_line: int;                (* Line number *)
+    mutable x_def: def option } (* Definition in scope *)
+
+
+(* Abstract syntax *)
+
+type program = Program of decl list * stmt
+
+and decl = Decl of name list * ptype
+
+and stmt = 
+    Skip 
+  | Seq of stmt list
+  | Assign of expr * expr
+  | Print of expr
+  | Newline
+  | IfStmt of expr * stmt * stmt
+  | WhileStmt of expr * stmt
+
+and expr = 
+  { e_guts: expr_guts;
+    mutable e_type: ptype }
+
+and expr_guts =
+    Constant of int * ptype
+  | Variable of name
+  | Sub of expr * expr
+  | Monop of Keiko.op * expr 
+  | Binop of Keiko.op * expr * expr
+
+
+(* seq -- neatly join a list of statements into a sequence *)
+val seq : stmt list -> stmt
+
+(* |makeName| -- construct a name node with dummy annotations *)
+val makeName : ident -> int -> name
+
+(* |get_def| -- rerieve definition from name *)
+val get_def : name -> def
+
+(* |makeExpr| -- construct an expr node with dummy annotations *)
+val makeExpr : expr_guts -> expr
+
+(* |print_tree| -- pretty-print a tree *)
+val print_tree : out_channel -> program -> unit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/Makefile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,82 @@
+# lab3/Makefile
+
+## Add your own test cases to this list
+TEST = gcd fac0 fac gcdfun sumpow sumpow2 bug digits
+
+all: ppc
+
+ppc: keiko.cmo lexer.cmo dict.cmo tree.cmo \
+		parser.cmo check.cmo peepopt.cmo kgen.cmo main.cmo
+	ocamlc -g ../lib/common.cma $^ -o $@
+
+parser.mli parser.ml: parser.mly
+	ocamlyacc parser.mly
+
+lexer.ml: lexer.mll
+	ocamllex lexer.mll
+
+KEIKO = ../keiko
+
+test: force
+	$(MAKE) $(TEST:%=test-%)
+
+test-%: force
+	@echo "*** Test $*.p"
+	./ppc $*.p >a.k
+	$(KEIKO)/pplink -nostdlib $(KEIKO)/lib.k a.k -o a.x >/dev/null
+	-$(KEIKO)/ppx ./a.x >a.test 2>&1
+	sed -n -e '1,/^(\*<</d' -e '/^>>\*)/q' -e p $*.p | diff - a.test
+	@echo "*** Passed"; echo
+
+realclean: clean
+
+clean: force
+	rm -f ppc a.k a.x a.out a.test
+	rm -f parser.mli parser.ml lexer.ml *.cma *.cmo *.cmi
+
+ML = check.ml check.mli dict.ml dict.mli keiko.ml keiko.mli kgen.ml \
+	kgen.mli lexer.ml lexer.mli main.ml parser.ml \
+	parser.mli tree.ml tree.mli peepopt.mli peepopt.ml
+
+depend : $(ML) force
+	(sed '/^###/q' Makefile; echo; ocamldep $(ML)) >new
+	mv new Makefile
+
+%.cmi : %.mli
+	ocamlc $(MLFLAGS) -c $<
+
+%.cmo : %.ml
+	ocamlc $(MLFLAGS) -c $<
+
+MLFLAGS = -I ../lib -g
+
+force:
+
+###
+
+check.cmo : tree.cmi dict.cmi check.cmi
+check.cmx : tree.cmx dict.cmx check.cmi
+check.cmi : tree.cmi
+dict.cmo : dict.cmi
+dict.cmx : dict.cmi
+dict.cmi :
+keiko.cmo : tree.cmi keiko.cmi
+keiko.cmx : tree.cmx keiko.cmi
+keiko.cmi :
+kgen.cmo : tree.cmi peepopt.cmi keiko.cmi dict.cmi kgen.cmi
+kgen.cmx : tree.cmx peepopt.cmx keiko.cmx dict.cmx kgen.cmi
+kgen.cmi : tree.cmi
+lexer.cmo : tree.cmi parser.cmi keiko.cmi lexer.cmi
+lexer.cmx : tree.cmx parser.cmx keiko.cmx lexer.cmi
+lexer.cmi : parser.cmi
+main.cmo : tree.cmi parser.cmi lexer.cmi kgen.cmi check.cmi
+main.cmx : tree.cmx parser.cmx lexer.cmx kgen.cmx check.cmx
+parser.cmo : tree.cmi lexer.cmi keiko.cmi parser.cmi
+parser.cmx : tree.cmx lexer.cmx keiko.cmx parser.cmi
+parser.cmi : tree.cmi keiko.cmi
+peepopt.cmo : keiko.cmi peepopt.cmi
+peepopt.cmx : keiko.cmx peepopt.cmi
+peepopt.cmi : keiko.cmi
+tree.cmo : keiko.cmi dict.cmi tree.cmi
+tree.cmx : keiko.cmx dict.cmx tree.cmi
+tree.cmi : keiko.cmi dict.cmi
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/bug.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,13 @@
+proc noret();
+begin
+end;
+
+begin
+  print noret()
+end.
+
+(*<<
+Runtime error: function failed to return a result in module Main
+In procedure noret_1
+   called from MAIN
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/check.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,160 @@
+(* lab3/check.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree 
+open Dict 
+open Print 
+
+(* |err_line| -- line number for error messages *)
+let err_line = ref 1
+
+(* |Semantic_error| -- exception raised if error detected *)
+exception Semantic_error of string * Print.arg list * int
+
+(* |sem_error| -- issue error message by raising exception *)
+let sem_error fmt args = 
+  raise (Semantic_error (fmt, args, !err_line))
+
+(* |accum| -- fold_left with arguments swapped *)
+let rec accum f xs a =
+  match xs with
+      [] -> a
+    | y::ys -> accum f ys (f y a)
+
+(* |lookup_def| -- find definition of a name, give error is none *)
+let lookup_def x env =
+  err_line := x.x_line;
+  try let d = lookup x.x_name env in x.x_def <- Some d; d with 
+    Not_found -> sem_error "$ is not declared" [fStr x.x_name]
+
+(* |add_def| -- add definition to env, give error if already declared *)
+let add_def d env =
+  try define d env with 
+    Exit -> sem_error "$ is already declared" [fStr d.d_tag]
+
+(* |check_expr| -- check and annotate an expression *)
+let rec check_expr e env =
+  match e with
+      Constant n -> ()
+    | Variable x -> 
+        let d = lookup_def x env in
+        begin
+          match d.d_kind with
+              VarDef -> ()
+            | ProcDef _ ->
+                sem_error "$ is not a variable" [fStr x.x_name]
+        end
+    | Monop (w, e1) -> 
+        check_expr e1 env
+    | Binop (w, e1, e2) -> 
+        check_expr e1 env;
+        check_expr e2 env
+    | Call (p, args) ->
+        let d = lookup_def p env in
+        begin
+          match d.d_kind with
+              VarDef ->
+                sem_error "$ is not a procedure" [fStr p.x_name]
+            | ProcDef nargs ->
+                if List.length args <> nargs then
+                  sem_error "procedure $ needs $ arguments" 
+                    [fStr p.x_name; fNum nargs];
+        end;
+        List.iter (fun e1 -> check_expr e1 env) args
+
+(* |check_stmt| -- check and annotate a statement *)
+let rec check_stmt s inproc env =
+  match s with
+      Skip -> ()
+    | Seq ss ->
+        List.iter (fun s1 -> check_stmt s1 inproc env) ss
+    | Assign (x, e) ->
+        let d = lookup_def x env in
+        begin
+          match d.d_kind with
+              VarDef -> check_expr e env
+            | ProcDef _ -> 
+                sem_error "$ is not a variable" [fStr x.x_name]
+        end
+    | Return e ->
+        if not inproc then
+          sem_error "return statement only allowed in procedure" [];
+        check_expr e env
+    | IfStmt (test, thenpt, elsept) ->
+        check_expr test env;
+        check_stmt thenpt inproc env;
+        check_stmt elsept inproc env
+    | WhileStmt (test, body) ->
+        check_expr test env;
+        check_stmt body inproc env
+    | Print e ->
+        check_expr e env
+    | Newline ->
+        ()
+
+(* |serialize| -- number a list, starting from 0 *)
+let serialize xs = 
+  let rec count i =
+    function
+        [] -> []
+      | x :: xs -> (i, x) :: count (i+1) xs in
+  count 0 xs
+
+(*
+Frame layout
+
+        arg n
+        ...
+fp+16:  arg 1
+fp+12:  static link
+fp+8:   current cp
+fp+4:   return addr
+fp:     dynamic link
+fp-4:   local 1
+        ...
+        local m
+*)
+
+let arg_base = 16
+let loc_base = 0
+
+(* |declare_local| -- declare a formal parameter or local *)
+let declare_local x lev off env =
+  let d = { d_tag = x; d_kind = VarDef; d_level = lev; 
+                d_lab = ""; d_off = off } in
+  add_def d env
+
+(* |declare_global| -- declare a global variable *)
+let declare_global x env =
+  let d = { d_tag = x; d_kind = VarDef; d_level = 0; 
+                d_lab = sprintf "_$" [fStr x]; d_off = 0 } in
+  add_def d env
+
+(* |declare_proc| -- declare a procedure *)
+let declare_proc (Proc (p, formals, body)) lev env =
+  let lab = sprintf "$_$" [fStr p.x_name; fNum (label ())] in
+  let d = { d_tag = p.x_name; 
+                d_kind = ProcDef (List.length formals); d_level = lev;
+                d_lab = lab; d_off = 0 } in
+  p.x_def <- Some d; add_def d env
+
+(* |check_proc| -- check a procedure body *)
+let rec check_proc (Proc (p, formals, Block (vars, procs, body))) lev env =
+  err_line := p.x_line;
+  let env' =
+    accum (fun (i, x) -> declare_local x lev (arg_base + 4*i))
+      (serialize formals) (new_block env) in
+  let env'' = 
+    accum (fun (i, x) -> declare_local x lev (loc_base - 4*(i+1)))
+      (serialize vars) env' in
+  let env''' = 
+    accum (fun d -> declare_proc d (lev+1)) procs env'' in
+  List.iter (fun d -> check_proc d (lev+1) env''') procs;
+  check_stmt body true env'''
+
+(* |annotate| -- check and annotate a program *)
+let annotate (Program (Block (vars, procs, body))) =
+  let env = accum declare_global vars empty in
+  let env' = accum (fun d -> declare_proc d 1) procs env in
+  List.iter (fun d -> check_proc d 1 env') procs;
+  check_stmt body false env'
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/check.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,10 @@
+(* lab3/check.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree
+
+(* |annotate| -- check tree for type errors and annotate with definitions *)
+val annotate : program -> unit
+
+(* |Semantic_error| -- exception raised if error detected *)
+exception Semantic_error of string * Print.arg list * int
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/compile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,13 @@
+#!/bin/sh
+
+# This hacked up version works, at least on Linux, even for people who
+# have spaces in the names of directories.  Sheesh.
+
+KEIKO=`cd ../keiko; pwd`
+
+set -x
+
+./ppc $* >a.k \
+    && "$KEIKO/pplink" -nostdlib -i "/usr/bin/env $KEIKO/ppx" \
+        "$KEIKO/lib.k" a.k -o a.out >/dev/null \
+    && chmod +x a.out
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/compose.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,26 @@
+(* lab3/compose.p *)
+
+var p;
+
+proc compose(f, g);
+  proc fg(x);
+  begin
+    return f(g(x))
+  end;
+begin
+  return fg
+end;
+
+proc dummy(f, g);
+  var a0, a1, a2, a3, a4, a5, a6, a7, a8, a9;
+begin
+  return compose(f, g)
+end;
+
+proc add2(x); begin return x+2 end;
+proc square(x); begin return x * x end;
+
+begin
+  p := dummy(square, add2);
+  print p(2); newline
+end.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/dict.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,57 @@
+(* lab3/dict.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(*
+Environments are implemented using a library module that 
+represents mappings by balanced binary trees.
+*)
+
+type ident = string
+
+type codelab = int
+
+(* |lab| -- last used code label *)
+let lab = ref 0
+
+(* |label| -- allocate a code label *)
+let label () = incr lab; !lab
+
+(* |def| -- definitions in environment *)
+type def = 
+  { d_tag : ident;              (* Name *)
+    d_kind : def_kind;          (* Definition *)
+    d_level : int;              (* Nesting level *)
+    d_lab : string;             (* Label if global *)
+    d_off : int }               (* Offset if local *)
+
+and def_kind =
+    VarDef                      (* Variable *)
+  | ProcDef of int              (* Procedure (nparams) *)
+
+let find_def x ds =
+  let rec search =
+    function
+        [] -> raise Not_found
+      | d::ds -> 
+          if x = d.d_tag then d else search ds in
+  search ds
+
+module IdMap = Map.Make(struct type t = ident  let compare = compare end)
+
+type environment = Env of def list * def IdMap.t
+
+let can f x = try f x; true with Not_found -> false
+
+(* |define| -- add a definition *)
+let define d (Env (b, m)) = 
+  if can (find_def d.d_tag) b then raise Exit;
+  Env (d::b, IdMap.add d.d_tag d m)
+
+(* |lookup| -- find definition of an identifier *)
+let lookup x (Env (b, m)) = IdMap.find x m
+
+(* |empty| -- empty environment *)
+let empty = Env ([], IdMap.empty)
+
+(* |new_block| -- add new block *)
+let new_block (Env (b, m)) = Env ([], m)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/dict.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,35 @@
+(* lab3/dict.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+type ident = string
+
+type codelab = int
+
+val label : unit -> codelab
+
+(* |def| -- definitions in environment *)
+type def = 
+  { d_tag : ident;              (* Name *)
+    d_kind : def_kind;          (* Definition *)
+    d_level : int;              (* Nesting level *)
+    d_lab : string;             (* Label if global *)
+    d_off : int }               (* Offset if local *)
+
+and def_kind =
+    VarDef                      (* Variable *)
+  | ProcDef of int              (* Procedure (nparams) *)
+
+type environment
+
+(* |define| -- add a definition, raise Exit if already declared *)
+val define : def -> environment -> environment
+
+(* |lookup| -- search an environment or raise Not_found *)
+val lookup : ident -> environment -> def
+
+(* |new_block| -- add new block to top of environment *)
+val new_block : environment -> environment
+
+(* |empty| -- initial empty environment *)
+val empty : environment
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/digits.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,45 @@
+(* lab3/digits.p *)
+
+var q;
+
+proc search(k, n, avail);
+
+  var d, nn;
+
+  proc avail1(x);
+  begin
+    if x <> d then
+      return avail(x)
+    else
+      return 0
+    end
+  end;
+
+begin
+  if k = 10 then
+    print n; newline
+  else
+    d := 1;
+    while d < 10 do
+      nn := 10 * n + d;
+      if avail(d) and (nn mod k = 0) then
+        q := search(k+1, nn, avail1)
+      end;
+      d := d+1
+    end
+  end;
+  return 0
+end;
+
+proc all(x);
+begin
+  return 1
+end;
+
+begin
+  q := search(1, 0, all)
+end.
+
+(*<<
+ 381654729
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/fac.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,18 @@
+(* lab3/fac.p *)
+
+proc fac(i);
+begin
+  if i = 0 then
+    return 1
+  else
+    return i * fac(i-1)
+  end
+end;
+
+begin
+  print fac(10); newline
+end.
+
+(*<<
+ 3628800
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/fac0.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,22 @@
+(* lab3/fac0.p *)
+
+var n, f;
+
+proc fac();
+begin
+  if n = 0 then
+    return f;
+  else
+    f := f*n; n := n-1; 
+    return fac()
+  end
+end;
+
+begin
+  n := 10; f := 1;
+  print fac(); newline
+end.
+
+(*<<
+ 3628800
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/gcd.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,19 @@
+(* lab3/gcd.p *)
+
+var x, y;
+
+begin
+  x := 3 * 37; y := 5 * 37;
+  while x <> y do
+    if x > y then
+      x := x - y
+    else
+      y := y - x
+    end
+  end;
+  print x; newline
+end.
+
+(*<<
+ 37
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/gcdfun.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,21 @@
+(* lab3/gcdfun.p *)
+
+proc gcd(x, y);   
+begin
+  while x <> y do
+    if x > y then
+      x := x - y
+    else
+      y := y - x
+    end
+  end;
+  return x
+end;
+
+begin
+  print gcd(3*37, 7*37); newline
+end.
+
+(*<<
+ 37
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/keiko.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,276 @@
+(* common/keiko.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree 
+open Print
+
+(* |codelab| -- type of code labels *)
+type codelab = int
+
+(* |lastlab| -- last used code label *)
+let lastlab = ref 0
+
+(* |label| -- allocate a code label *)
+let label () = incr lastlab; !lastlab
+
+(* |fLab| -- format a code label for printf *)
+let fLab n = fMeta "L$" [fNum n]
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
+
+(* |code| -- type of intermediate instructions *)
+type code =
+    CONST of int                (* Push constant (value) *)
+  | GLOBAL of string            (* Push global address (name) *)
+  | LOCAL of int                (* Push local adddress (offset) *)
+  | LOADW                       (* Load word *)
+  | STOREW                      (* Store word *)
+  | LOADC                       (* Load character *)
+  | STOREC                      (* Store character *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (op, dest) *)
+  | PCALL of int                (* Call procedure *)
+  | PCALLW of int               (* Proc call with result (nargs) *)
+  | RETURNW                     (* Return from procedure *)
+  | BOUND of int                (* Bounds check *)
+  | CASEJUMP of int             (* Case jump (num cases) *)
+  | CASEARM of int * codelab    (* Case value and label *)
+  | PACK                        (* Pack two values into one *)
+  | UNPACK                      (* Unpack one value into two *)
+  | DUP
+  | POP
+
+  | LDGW of string              (* Load Global Word (name) *)
+  | STGW of string              (* Store Global Word (name) *)
+  | LDLW of int                 (* Load Local Word (offset) *)
+  | STLW of int                 (* Store Local Word (offset) *)
+  | LDNW of int                 (* Load word with offset *)
+  | STNW of int                 (* Store word with offset *)
+
+  | LINE of int
+  | SEQ of code list
+  | NOP
+
+(* op_name -- map an operator to its name *)
+let op_name =
+  function
+      Plus -> "Plus" | Minus -> "Minus" | Times -> "Times"
+    | Div -> "Div" | Mod -> "Mod" | Eq -> "Eq"
+    | Uminus -> "Uminus" | Lt -> "Lt" | Gt -> "Gt" 
+    | Leq -> "Leq" | Geq -> "Geq" | Neq -> "Neq" 
+    | And -> "And" | Or -> "Or" | Not -> "Not"
+
+(* fOp -- format an operator as an instruction *)
+let fOp w =
+  (* Avoid the deprecated String.uppercase *)
+  let upc ch =
+    if ch >= 'a' && ch <= 'z' then Char.chr (Char.code ch - 32) else ch in
+  fStr (String.map upc (op_name w))
+
+(* |fInst| -- format an instruction for |printf| *)
+let fInst =
+  function
+      CONST x ->        fMeta "CONST $" [fNum x]
+    | GLOBAL a ->       fMeta "GLOBAL $" [fStr a]
+    | LOCAL n ->        fMeta "LOCAL $" [fNum n]
+    | LOADW ->          fStr "LOADW"
+    | STOREW ->         fStr "STOREW"
+    | LOADC ->          fStr "LOADC"
+    | STOREC ->         fStr "STOREC"
+    | MONOP w ->        fOp w
+    | BINOP w ->        fOp w
+    | OFFSET ->         fStr "OFFSET"
+    | LABEL l ->        fMeta "LABEL $" [fLab l]
+    | JUMP l ->         fMeta "JUMP $" [fLab l]
+    | JUMPC (w, l) ->   fMeta "J$ $" [fOp w; fLab l]
+    | PCALL n ->        fMeta "PCALL $" [fNum n]
+    | PCALLW n ->       fMeta "PCALLW $" [fNum n]
+    | RETURNW ->        fStr "RETURNW"
+    | BOUND n ->        fMeta "BOUND $" [fNum n]
+    | CASEJUMP n ->     fMeta "CASEJUMP $" [fNum n]
+    | CASEARM (v, l) -> fMeta "CASEARM $ $" [fNum v; fLab l]
+    | PACK ->           fStr "PACK"
+    | UNPACK ->         fStr "UNPACK"
+    | DUP ->            fStr "DUP 0"
+    | POP ->            fStr "POP 1"
+    | LDGW a ->         fMeta "LDGW $" [fStr a]
+    | STGW a ->         fMeta "STGW $" [fStr a]
+    | LDLW n ->         fMeta "LDLW $" [fNum n]
+    | STLW n ->         fMeta "STLW $" [fNum n]
+    | LDNW n ->         fMeta "LDNW $" [fNum n]
+    | STNW n ->         fMeta "STNW $" [fNum n]
+    | LINE n ->         fMeta "LINE $" [fNum n]
+    | SEQ _ ->          fStr "SEQ ..."
+    | NOP ->            fStr "NOP"
+
+let mark_line n ys =
+  if n = 0 then ys else
+    match ys with
+        [] | LINE _ :: _ -> ys
+      | _ -> LINE n :: ys
+
+(* |canon| -- flatten a code sequence *)
+let canon x =
+  let rec accum x ys =
+    match x with
+        SEQ xs -> List.fold_right accum xs ys
+      | NOP -> ys
+      | LINE n -> 
+          if n = 0 then 
+            ys 
+          else begin
+            match ys with
+                [] -> ys
+              | LINE _ :: _ -> ys
+              | _ -> LINE n :: ys
+          end
+      | _ -> x :: ys in
+  SEQ (accum x [])
+
+
+(* SANITY CHECKS *)
+
+(* The checks implemented here ensure that the value stack is used in a 
+   consistent way, and that CASEJUMP instructions are followed by the 
+   correct number of case labels.  There are a few assumptions, the main
+   one being that backwards jumps leave nothing on the stack. *)
+
+(* Compute pair (a, b) if an instruction pops a values and pushes b *)
+let delta =
+  function
+      CONST _ | GLOBAL _ | LOCAL _ | LDGW _ | LDLW _ -> (0, 1)
+    | STGW _ | STLW _ -> (1, 0)
+    | LOADW | LOADC | LDNW _ -> (1, 1)
+    | STOREW | STOREC | STNW _ -> (2, 0)
+    | MONOP _ -> (1, 1)
+    | BINOP _ | OFFSET -> (2, 1)
+    | PCALL n -> (n+2, 0)
+    | PCALLW n -> (n+2, 1)
+    | RETURNW -> (1, 0)
+    | BOUND _ -> (2, 1)
+    | PACK -> (2, 1)
+    | UNPACK -> (1, 2)
+    | LINE _ -> (0, 0)
+    | DUP -> (1, 2)
+    | POP -> (1, 0)
+    | i -> failwith (sprintf "delta $" [fInst i])
+
+(* Output code and check for basic sanity *)
+let check_and_output code =
+  let line = ref 0 in
+
+  (* Output an instruction *)
+  let out =
+    function 
+        LINE n -> 
+          if n <> 0 && !line <> n then begin
+            printf "! $\n" [fStr (Source.get_line n)];
+            line := n
+          end
+      | x -> printf "$\n" [fInst x] in
+
+  (* Report failure of sanity checks *)
+  let insane fmt args =
+    fprintf stderr "WARNING: Code failed sanity checks -- $\n" [fMeta fmt args];
+    printf "! *** HERE!\n" [];
+    raise Exit in
+
+  (* Map labels to (depth, flag) pairs *)
+  let labdict = Hashtbl.create 50 in
+
+  (* Note the depth at a label and check for consistency *)
+  let note_label lab def d =
+    try 
+      let (d1, f) = Hashtbl.find labdict lab in
+      if d >= 0 && d <> d1 then
+        insane "inconsistent stack depth ($ <> $) at label $" 
+          [fNum d; fNum d1; fNum lab];
+      if def then begin
+        if !f then insane "multiply defined label $" [fNum lab];
+        f := true
+      end;
+      d1
+    with Not_found ->
+      (* If this point is after an unconditional jump (d < 0) and 
+         the label is not defined previously, assume depth 0 *)
+      let d1 = max d 0 in
+      Hashtbl.add labdict lab (d1, ref def);
+      d1 in
+
+  (* Check all mentioned labels have been defined *)
+  let check_labs () =
+    Hashtbl.iter (fun lab (d, f) -> 
+      if not !f then insane "label $ is not defined" [fNum lab]) labdict in
+
+  let tail = ref [] in
+
+  let output () = out (List.hd !tail); tail := List.tl !tail in
+
+  (* Scan an instruction sequence, keeping track of the stack depth *)
+  let rec scan d = 
+    match !tail with
+        [] -> 
+          if d <> 0 then insane "stack not empty at end" []
+      | x :: _ ->
+          let need a =
+            if d < a then 
+              insane "stack underflow at instruction $" [fInst x] in
+          output ();
+          begin match x with
+              LABEL lab -> 
+                scan (note_label lab true d)
+            | JUMP lab -> 
+                unreachable (note_label lab false d)
+            | JUMPC (_, lab) -> 
+                need 2; scan (note_label lab false (d-2))
+            | CASEARM (_, _) -> 
+                insane "unexpected CASEARM" []
+            | CASEJUMP n -> 
+                need 1; jumptab n (d-1)
+            | SEQ _ | NOP -> 
+                failwith "sanity2"
+            | _ -> 
+                let (a, b) = delta x in need a; scan (d-a+b)
+          end
+
+  (* Scan a jump table, checking for the correct number of entries *)
+  and jumptab n d =
+    match !tail with
+        CASEARM (_, lab) :: _ -> 
+          output ();
+          if n = 0 then
+            insane "too many CASEARMs after CASEJUMP" [];
+          jumptab (n-1) (note_label lab false d)
+      | _ -> 
+          if n > 0 then
+            insane "too few CASEARMs after CASEJUMP" [];
+          scan d
+
+  (* Scan code after an unconditional jump *)
+  and unreachable d =
+    match !tail with
+        [] -> ()
+      | LABEL lab :: _ ->
+          output ();
+          scan (note_label lab true (-1))
+      | _ -> 
+          (* Genuinely unreachable code -- assume stack is empty *)
+          scan 0 in
+
+  match canon code with
+      SEQ xs -> 
+        tail := xs; 
+        (try scan 0; check_labs () with Exit -> 
+          (* After error, output rest of code without checks *)
+          List.iter out !tail; exit 1)
+    | _ -> failwith "sanity"
+
+let output code = 
+  try check_and_output code with Exit -> exit 1
+    
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/keiko.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,61 @@
+(* common/keiko.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |codelab| -- type of code labels *)
+type codelab = int
+
+(* |label| -- allocate a code label *)
+val label : unit -> codelab
+
+(* |op| -- type of picoPascal operators *)
+type op = Plus | Minus | Times | Div | Mod | Eq 
+  | Uminus | Lt | Gt | Leq | Geq | Neq | And | Or | Not
+
+(* op_name -- map an operator to its name *)
+val op_name : op -> string
+
+(* |code| -- type of intermediate instructions *)
+type code =
+    CONST of int                (* Push constant (value) *)
+  | GLOBAL of string            (* Push global address (name) *)
+  | LOCAL of int                (* Push local adddress (offset) *)
+  | LOADW                       (* Load word *)
+  | STOREW                      (* Store word *)
+  | LOADC                       (* Load character *)
+  | STOREC                      (* Store character *)
+  | MONOP of op                 (* Perform unary operation (op) *)
+  | BINOP of op                 (* Perform binary operation (op) *)
+  | OFFSET                      (* Add address and offset *)
+  | LABEL of codelab            (* Set code label *)
+  | JUMP of codelab             (* Unconditional branch (dest) *)
+  | JUMPC of op * codelab       (* Conditional branch (op, dest) *)
+  | PCALL of int                (* Call procedure *)
+  | PCALLW of int               (* Proc call with result (nargs) *)
+  | RETURNW                     (* Return from procedure *)
+  | BOUND of int                (* Bounds check *)
+  | CASEJUMP of int             (* Case jump (num cases) *)
+  | CASEARM of int * codelab    (* Case value and label *)
+  | PACK                        (* Pack two values into one *)
+  | UNPACK                      (* Unpack one value into two *)
+  | DUP
+  | POP
+
+  | LDGW of string              (* Load Global Word (name) *)
+  | STGW of string              (* Store Global Word (name) *)
+  | LDLW of int                 (* Load Local Word (offset) *)
+  | STLW of int                 (* Store Local Word (offset) *)
+  | LDNW of int                 (* Load word with offset *)
+  | STNW of int                 (* Store word with offset *)
+
+  | LINE of int
+  | SEQ of code list
+  | NOP
+
+(* |fInst| -- format an instruction for |printf| *)
+val fInst : code -> Print.arg
+
+(* |canon| -- flatten a code sequence *)
+val canon : code -> code
+
+(* |output| -- output a code sequence *)
+val output : code -> unit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/kgen.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,113 @@
+(* lab3/kgen.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Tree 
+open Dict 
+open Keiko 
+open Print 
+
+let optflag = ref false
+
+let level = ref 0
+
+let slink = 12
+
+(* |gen_addr| -- generate code to push address of a variable *)
+let gen_addr d =
+  if d.d_level = 0 then
+    GLOBAL d.d_lab
+  else
+    failwith "local variables not implemented yet"
+
+(* |gen_expr| -- generate code for an expression *)
+let rec gen_expr =
+  function
+      Variable x ->
+        let d = get_def x in
+        begin
+          match d.d_kind with
+              VarDef ->
+                SEQ [LINE x.x_line; gen_addr d; LOADW]
+            | ProcDef nargs -> 
+                failwith "no procedure values"
+        end
+    | Constant x ->
+        CONST x
+    | Monop (w, e1) ->
+        SEQ [gen_expr e1; MONOP w]
+    | Binop (w, e1, e2) ->
+        SEQ [gen_expr e1; gen_expr e2; BINOP w]
+    | Call (p, args) ->
+        SEQ [LINE p.x_line;
+          failwith "no procedure call"]
+
+(* |gen_cond| -- generate code for short-circuit condition *)
+let rec gen_cond e tlab flab =
+  (* Jump to |tlab| if |e| is true and |flab| if it is false *)
+  match e with
+      Constant x ->
+        if x <> 0 then JUMP tlab else JUMP flab
+    | Binop ((Eq|Neq|Lt|Gt|Leq|Geq) as w, e1, e2) ->
+        SEQ [gen_expr e1; gen_expr e2;
+          JUMPC (w, tlab); JUMP flab]
+    | Monop (Not, e1) ->
+        gen_cond e1 flab tlab
+    | Binop (And, e1, e2) ->
+        let lab1 = label () in
+        SEQ [gen_cond e1 lab1 flab; LABEL lab1; gen_cond e2 tlab flab]
+    | Binop (Or, e1, e2) ->
+        let lab1 = label () in
+        SEQ [gen_cond e1 tlab lab1; LABEL lab1; gen_cond e2 tlab flab]
+    | _ ->
+        SEQ [gen_expr e; CONST 0; JUMPC (Neq, tlab); JUMP flab]
+
+(* |gen_stmt| -- generate code for a statement *)
+let rec gen_stmt =
+  function
+      Skip -> NOP
+    | Seq ss ->
+        SEQ (List.map gen_stmt ss)
+    | Assign (v, e) ->
+        let d = get_def v in
+        begin
+          match d.d_kind with
+              VarDef ->
+                SEQ [gen_expr e; gen_addr d; STOREW]
+           | _ -> failwith "assign"
+        end
+    | Print e ->
+        SEQ [gen_expr e; CONST 0; GLOBAL "lib.print"; PCALL 1]
+    | Newline ->
+        SEQ [CONST 0; GLOBAL "lib.newline"; PCALL 0]
+    | IfStmt (test, thenpt, elsept) ->
+        let lab1 = label () and lab2 = label () and lab3 = label () in
+        SEQ [gen_cond test lab1 lab2; 
+          LABEL lab1; gen_stmt thenpt; JUMP lab3;
+          LABEL lab2; gen_stmt elsept; LABEL lab3]
+    | WhileStmt (test, body) ->
+        let lab1 = label () and lab2 = label () and lab3 = label () in
+        SEQ [JUMP lab2; LABEL lab1; gen_stmt body; 
+          LABEL lab2; gen_cond test lab1 lab3; LABEL lab3]
+    | Return e ->
+        failwith "no return statement"
+
+(* |gen_proc| -- generate code for a procedure *)
+let rec gen_proc (Proc (p, formals, Block (vars, procs, body))) =
+  let d = get_def p in
+  level := d.d_level;
+  let code = gen_stmt body in
+  printf "PROC $ $ 0 0\n" [fStr d.d_lab; fNum (4 * List.length vars)];
+  Keiko.output (if !optflag then Peepopt.optimise code else code);
+  printf "ERROR E_RETURN 0\n" [];
+  printf "END\n\n" [];
+  List.iter gen_proc procs
+
+(* |translate| -- generate code for the whole program *)
+let translate (Program (Block (vars, procs, body))) =
+  level := 0;
+  printf "PROC MAIN 0 0 0\n" [];
+  Keiko.output (gen_stmt body);
+  printf "RETURN\n" [];
+  printf "END\n\n" [];
+  List.iter gen_proc procs;
+  List.iter (function x -> printf "GLOVAR _$ 4\n" [fStr x]) vars
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/kgen.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,7 @@
+(* lab3/kgen.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |translate| -- generate intermediate code *)
+val translate : Tree.program -> unit
+
+val optflag : bool ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/lexer.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,15 @@
+(* lab3/lexer.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(*
+The lexer is generated from a camllex script.  It takes an input
+buffer, reads a token, and returns the |token| value that corresponds
+to it.  The lexer maintains the current line number in |lineno| for
+producing error messages.
+*)
+
+(* |token| -- scan a token and return its code *)
+val token : Lexing.lexbuf -> Parser.token
+
+(* |lineno| -- number of current line *)
+val lineno : int ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/lexer.mll	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,61 @@
+(* lab3/lexer.mll *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+{
+open Keiko
+open Parser 
+open Tree 
+open Lexing 
+
+let make_hash n ps =
+  let t = Hashtbl.create n in
+  List.iter (fun (k, v) -> Hashtbl.add t k v) ps;
+  t
+
+(* A little table to recognize keywords *)
+let kwtable = 
+  make_hash 64
+    [ ("begin", BEGIN); ("end", END); ("var", VAR); ("print", PRINT);
+      ("if", IF); ("then", THEN); ("else", ELSE); ("while", WHILE); 
+      ("do", DO); ("proc", PROC); ("return", RETURN); ("newline", NEWLINE);
+      ("true", NUMBER 1); ("false", NUMBER 0); 
+      ("and", MULOP And); ("div", MULOP Div); ("or", ADDOP Or);
+      ("not", MONOP Not); ("mod", MULOP Mod) ]
+
+let lookup s = try Hashtbl.find kwtable s with Not_found -> IDENT s
+
+let lineno = ref 1
+}
+
+rule token = parse
+  ['A'-'Z''a'-'z']['A'-'Z''a'-'z''0'-'9''_']* as s
+                        { lookup s }
+| ['0'-'9']+ as s       { NUMBER (int_of_string s) }
+| "="                   { RELOP Eq }
+| "+"                   { ADDOP Plus }
+| "-"                   { MINUS }
+| "*"                   { MULOP Times }
+| "<"                   { RELOP Lt }
+| ">"                   { RELOP Gt }
+| "<>"                  { RELOP Neq }
+| "<="                  { RELOP Leq }
+| ">="                  { RELOP Geq }
+| "("                   { LPAR }
+| ")"                   { RPAR }
+| ","                   { COMMA }
+| ";"                   { SEMI }
+| "."                   { DOT }
+| ":="                  { ASSIGN }
+| [' ''\t']+            { token lexbuf }
+| "(*"                  { comment lexbuf; token lexbuf }
+| '\n'                  { incr lineno; Source.note_line !lineno lexbuf;
+                          token lexbuf }
+| _                     { BADTOK }
+| eof                   { EOF }
+
+and comment = parse
+  "*)"                  { () }
+| "\n"                  { incr lineno; Source.note_line !lineno lexbuf;
+                          comment lexbuf }
+| _                     { comment lexbuf }
+| eof                   { () }
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/main.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,44 @@
+(* lab3/main.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Print 
+open Source
+
+(* |main| -- main program *)
+let main () =
+  let dflag = ref false in
+  let fns = ref [] in
+  let usage =  "Usage: ppc [-d] file.p" in
+  Arg.parse [("-d", Arg.Set dflag, " Print the tree");
+      ("-O", Arg.Unit (fun () -> Kgen.optflag := true), " Peephole optimiser")]
+    (function s -> fns := !fns @ [s]) usage;
+  if List.length !fns <> 1 then begin 
+    fprintf stderr "$\n" [fStr usage]; exit 2 
+  end;
+  let in_file = List.hd !fns in
+  let in_chan = open_in in_file in
+  Source.init in_file in_chan;
+  let lexbuf = Lexing.from_channel in_chan in
+  let prog = try Parser.program Lexer.token lexbuf with
+      Parsing.Parse_error ->
+        let tok = Lexing.lexeme lexbuf in
+        err_message "syntax error at token '$'" 
+          [fStr tok] !Lexer.lineno;
+        exit 1 in
+
+  if !dflag then Tree.print_tree stdout prog;
+
+  begin try Check.annotate prog with
+      Check.Semantic_error (fmt, args, line) ->
+        err_message fmt args line;
+        exit 1
+  end;
+
+  printf "MODULE Main 0 0\n" [];
+  printf "IMPORT Lib 0\n" [];
+  printf "ENDHDR\n\n" [];
+
+  Kgen.translate prog;
+  exit 0
+
+let ppc = main ()
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/parser.mly	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,92 @@
+/* lab3/parser.mly */
+/* Copyright (c) 2017 J. M. Spivey */
+
+%token<string>  IDENT
+%token<int>     NUMBER
+%token<Keiko.op> MONOP MULOP ADDOP RELOP
+%token          MINUS LPAR RPAR COMMA SEMI DOT ASSIGN EOF BADTOK
+%token          BEGIN END VAR PRINT IF THEN ELSE WHILE DO PROC RETURN NEWLINE
+
+%start          program
+%type<Tree.program> program
+
+%{
+open Keiko
+open Tree
+%}
+
+%%
+
+program :
+    block DOT                           { Program $1 } ;
+
+block :
+    var_decl proc_decls BEGIN stmts END  { Block ($1, $2, $4) } ;
+
+var_decl :
+    /* empty */                         { [] }
+  | VAR ident_list SEMI                 { $2 } ;
+
+ident_list :
+    IDENT                               { [$1] }
+  | IDENT COMMA ident_list              { $1::$3 } ;
+
+proc_decls :
+    /* empty */                         { [] }
+  | proc_decl proc_decls                { $1::$2 } ;
+
+proc_decl :
+    PROC name formals SEMI block SEMI   { Proc ($2, $3, $5) } ;
+
+formals :
+    LPAR RPAR                           { [] } ;
+  | LPAR ident_list RPAR                { $2 } ;
+
+stmts :
+    stmt_list                           { seq $1 } ;
+
+stmt_list :
+    stmt                                { [$1] }
+  | stmt SEMI stmt_list                 { $1::$3 } ;
+
+stmt :
+    /* empty */                         { Skip }
+  | name ASSIGN expr                    { Assign ($1, $3) }
+  | RETURN expr                         { Return $2 }
+  | IF expr THEN stmts END              { IfStmt ($2, $4, Skip) }
+  | IF expr THEN stmts ELSE stmts END   { IfStmt ($2, $4, $6) }
+  | WHILE expr DO stmts END             { WhileStmt ($2, $4) }
+  | PRINT expr                          { Print $2 } 
+  | NEWLINE                             { Newline } ;
+
+actuals :
+    LPAR RPAR                           { [] }
+  | LPAR expr_list RPAR                 { $2 } ;
+
+expr_list :
+    expr                                { [$1] }
+  | expr COMMA expr_list                { $1::$3 } ;
+
+expr :
+    simple                              { $1 }
+  | expr RELOP simple                   { Binop ($2, $1, $3) } ;
+
+simple :
+    term                                { $1 }
+  | simple ADDOP term                   { Binop ($2, $1, $3) }
+  | simple MINUS term                   { Binop (Minus, $1, $3) } ;
+
+term :
+    factor                              { $1 }
+  | term MULOP factor                   { Binop ($2, $1, $3) } ;
+
+factor :
+    NUMBER                              { Constant $1 } 
+  | name                                { Variable $1 }
+  | name actuals                        { Call ($1, $2) }
+  | MONOP factor                        { Monop ($1, $2) }
+  | MINUS factor                        { Monop (Uminus, $2) }
+  | LPAR expr RPAR                      { $2 } ;
+
+name :
+    IDENT                               { makeName $1 !Lexer.lineno } ;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/peepopt.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,172 @@
+(* ppc/peepopt.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Keiko
+open Print
+
+let debug = ref 0
+
+(* Disjoint sets of labels *)
+
+type lab_data = 
+    LabDef of labrec                    (* An extant label *)
+  | Equiv of codelab                    (* A label that's been merged *)
+
+and labrec =
+  { y_id: codelab;                      (* Name of the label *)
+    y_refct: int ref }                  (* Reference count *)
+
+(* |label_tab| -- map labels to their equivalents *)
+let label_tab = Hashtbl.create 257
+
+(* |get_label| -- get equivalence cell for a label *)
+let get_label x =
+  try !(Hashtbl.find label_tab x) with
+    Not_found ->
+      let y = LabDef { y_id = x; y_refct = ref 0 } in
+      Hashtbl.add label_tab x (ref y); y
+
+(* |find_label| -- find data about equivalence class of a label *)
+let rec find_label x =
+  match get_label x with
+      LabDef y -> y
+    | Equiv x' -> find_label x'
+
+(* |rename| -- get canonical equivalent of a label *)
+let rename x = let y = find_label x in y.y_id
+
+(* |ref_count| -- get reference count cell for a label *)
+let ref_count x = let y = find_label x in y.y_refct
+
+(* |same_lab| -- test if two labels are equivalent *)
+let same_lab x1 x2 = (rename x1 = rename x2)
+
+(* |equate| -- make two labels equivalent *)
+let equate x1 x2 =
+  let y1 = find_label x1 and y2 = find_label x2 in
+  if y1.y_id = y2.y_id then failwith "equate";
+  y2.y_refct := !(y1.y_refct) + !(y2.y_refct);
+  Hashtbl.find label_tab y1.y_id := Equiv y2.y_id
+
+(* |do_refs| -- call function on refcount of each label in an instruction *)
+let do_refs f =
+  function
+      JUMP x -> f (ref_count x)
+    | JUMPC (w, x) -> f (ref_count x)
+    | CASEARM (n, x) -> f (ref_count x)
+    | _ -> ()
+
+(* |rename_labs| -- replace each label by its equivalent *)
+let rename_labs =
+  function
+      LABEL x -> LABEL (rename x)
+    | JUMP x -> JUMP (rename x)
+    | JUMPC (w, x) -> JUMPC (w, rename x)
+    | CASEARM (n, x) -> CASEARM (n, rename x)
+    | i -> i
+
+let opposite =
+  function Eq -> Neq | Neq -> Eq | Lt  -> Geq
+    | Leq -> Gt | Gt  -> Leq | Geq -> Lt
+    | _ -> failwith "opposite"
+
+(* |ruleset| -- simplify and introduce abbreviations *)
+let ruleset replace =
+  function
+      LOCAL a :: CONST b :: OFFSET :: _ ->
+        replace 3 [LOCAL (a+b)]
+    | CONST a :: OFFSET :: CONST b :: OFFSET :: _ ->
+        replace 4 [CONST (a+b); OFFSET]
+    | CONST 0 :: OFFSET :: _ ->
+        replace 2 []
+     
+    | GLOBAL x :: LOADW :: _ ->
+        replace 2 [LDGW x]
+    | GLOBAL x :: STOREW :: _ ->
+        replace 2 [STGW x]
+    | LOCAL n :: LOADW :: _ ->
+        replace 2 [LDLW n]
+    | LOCAL n :: STOREW :: _ ->
+        replace 2 [STLW n]
+    | CONST n :: OFFSET :: LOADW :: _ ->
+        replace 3 [LDNW n]
+    | CONST n :: OFFSET :: STOREW :: _ ->
+        replace 3 [STNW n]
+
+    | CONST x :: CONST n :: BOUND _ :: _ when x >= 0 && x < n ->
+        replace 3 [CONST x]
+
+    | LINE n :: LABEL a :: _ ->
+        replace 2 [LABEL a; LINE n]
+    | LINE n :: LINE m :: _ ->
+        replace 1 []
+    | LABEL a :: LABEL b :: _ ->
+        equate a b; replace 2 [LABEL a]
+    | LABEL a :: JUMP b :: _ when not (same_lab a b) ->
+        equate a b; replace 2 [JUMP b]
+    | JUMPC (w, a) :: JUMP b :: LABEL c :: _ when same_lab a c ->
+        replace 2 [JUMPC (opposite w, b)]
+    | JUMP a :: LABEL b :: _ when same_lab a b ->
+        replace 1 []
+    | JUMP a :: LABEL b :: _ -> 
+        ()
+    | JUMP a :: _ :: _ ->
+        replace 2 [JUMP a]
+    | LABEL a :: _ when !(ref_count a) = 0 ->
+        replace 1 []
+
+    | _ -> ()
+
+(* |take n [x1; x2; ...] = [x1; x2; ...; xn]| *)
+let rec take n =
+  function
+      [] -> []
+    | x::xs -> if n = 0 then [] else x :: take (n-1) xs
+
+(* |drop n [x1; x2; ...] = [x_{n+1}; x_{n+2}; ...]| *)
+let rec drop n =
+  function
+      [] -> []
+    | x::xs -> if n = 0 then x::xs else drop (n-1) xs
+
+(* |optstep| -- apply rules at one place in the buffer *)
+let optstep rules changed code =
+  let ch = ref true in
+  let replace n c = 
+    changed := true; ch := true;
+  if !debug > 0 then
+      printf "! $ --> $\n" [fList(fInst) (take n !code); fList(fInst) c];
+    List.iter (do_refs decr) (take n !code);
+    List.iter (do_refs incr) c; 
+    code := c @ drop n !code in
+  while !ch do
+    ch := false; rules replace !code
+  done
+
+(* |rewrite| -- iterate over the code and apply rules *)
+let rewrite rules prog =
+  let code1 = ref prog and code2 = ref [] in
+  let changed = ref true in
+  while !changed do
+    changed := false;
+    while !code1 <> [] do
+      optstep rules changed code1;
+      if !code1 <> [] then begin
+        code2 := rename_labs (List.hd !code1) :: !code2;
+        code1 := List.tl !code1
+      end
+    done;
+    code1 := List.rev !code2;
+    code2 := []
+  done;
+  !code1
+
+(* |optimise| -- rewrite list of instructions *)
+let optimise prog =
+  match Keiko.canon prog with
+      SEQ code ->
+        List.iter (do_refs incr) code;
+        let code2 = rewrite ruleset code in
+        Hashtbl.clear label_tab;
+        SEQ code2
+    | _ -> failwith "optimise"
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/peepopt.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,8 @@
+(* ppc/peepopt.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+(* |optimise| -- rewrite list of instructions *)
+val optimise : Keiko.code -> Keiko.code
+
+(* |debug| -- debugging level *)
+val debug: int ref
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/sumpow.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,31 @@
+(* lab3/sumpow.p *)
+
+proc sumpow(n, k);
+  var m, s;
+
+  proc pow(p);
+    var j, q;
+  begin
+    j := 0; q := 1;
+    while j < k do 
+      j := j+1; q := q*p
+    end;
+    return q
+  end;
+
+begin
+  m := 0; s := 0;
+  while m < n do 
+    m := m + 1; 
+    s := s + pow(m)
+  end;
+  return s
+end;
+
+begin
+  print sumpow(5, 4); newline
+end.
+
+(*<<
+ 979
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/sumpow2.p	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,36 @@
+(* lab3/sumpow2.p *)
+
+proc sum(n, f);
+  var m, s;
+begin
+  m := 0; s := 0;
+  while m < n do 
+    m := m + 1; 
+    s := s + f(m)
+  end;
+  return s
+end;
+
+proc sumpow(n, k);
+
+  proc pow(p);
+    var j, q;
+  begin
+    j := 0; q := 1;
+    while j < k do 
+      j := j+1; q := q*p
+    end;
+    return q
+  end;
+
+begin
+  return sum(n, pow)
+end;
+
+begin
+  print sumpow(5, 4); newline
+end.
+
+(*<<
+ 979
+>>*)
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/tree.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,104 @@
+(* lab3/tree.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Dict
+open Print
+
+(* |name| -- type for applied occurrences with annotations *)
+type name = 
+  { x_name: ident;              (* Name of the reference *)
+    x_line: int;                (* Line number *)
+    mutable x_def: def option } (* Definition in scope *)
+
+type expr = 
+    Constant of int
+  | Variable of name
+  | Monop of Keiko.op * expr
+  | Binop of Keiko.op * expr * expr
+  | Call of name * expr list
+
+type stmt =
+    Skip
+  | Seq of stmt list
+  | Assign of name * expr
+  | Return of expr
+  | IfStmt of expr * stmt * stmt
+  | WhileStmt of expr * stmt
+  | Print of expr
+  | Newline
+
+type block = Block of ident list * proc list * stmt
+
+and proc = Proc of name * ident list * block
+
+type program = Program of block
+
+let seq =
+  function
+      [] -> Skip                (* Use Skip in place of Seq [] *)
+    | [s] -> s                  (* Don't use a Seq node for one element *)
+    | ss -> Seq ss
+
+let makeName x ln = 
+  { x_name = x; x_line = ln; x_def = None }
+
+let get_def x =
+  match x.x_def with
+      Some d -> d
+    | None -> failwith (sprintf "missing def on $" [fStr x.x_name])
+
+
+(* Pretty printer *)
+
+open Print
+
+let fTail f xs =
+  let g prf = List.iter (fun x -> prf "; $" [f x]) xs in fExt g
+
+let fList f =
+  function
+      [] -> fStr "[]"
+    | x::xs -> fMeta "[$$]" [f x; fTail(f) xs]
+
+let fName x = fStr x.x_name
+
+let rec fExpr =
+  function
+      Constant n ->
+        fMeta "Number_$" [fNum n]
+    | Variable x -> 
+        fMeta "Variable_$" [fName x]
+    | Monop (w, e1) -> 
+        fMeta "Monop_($, $)" [fStr (Keiko.op_name w); fExpr e1]
+    | Binop (w, e1, e2) -> 
+        fMeta "Binop_($, $, $)" [fStr (Keiko.op_name w); fExpr e1; fExpr e2]
+    | Call (x, es) ->
+        fMeta "Call_($, $)" [fName x; fList(fExpr) es]
+
+let rec fStmt = 
+  function
+      Skip -> 
+        fStr "Skip"
+    | Seq ss -> 
+        fMeta "Seq_$" [fList(fStmt) ss]
+    | Assign (x, e) -> 
+        fMeta "Assign_($, $)" [fName x; fExpr e]
+    | Return e ->
+        fMeta "Return_($)" [fExpr e]
+    | Print e -> 
+        fMeta "Print_($)" [fExpr e]
+    | Newline -> 
+        fStr "Newline"
+    | IfStmt (e, s1, s2) ->
+        fMeta "IfStmt_($, $, $)" [fExpr e; fStmt s1; fStmt s2]
+    | WhileStmt (e, s) -> 
+        fMeta "WhileStmt_($, $)" [fExpr e; fStmt s]
+
+let rec fBlock (Block (vs, ps, body)) =
+  fMeta "Block_($, $, $)" [fList(fStr) vs; fList(fProc) ps; fStmt body]
+
+and fProc (Proc (x, fps, body)) =
+  fMeta "Proc_($, $, $)" [fName x; fList(fStr) fps; fBlock body]
+
+let print_tree fp (Program b) =
+  fgrindf fp "" "Program_($)" [fBlock b]
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab3/tree.mli	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,45 @@
+(* lab3/tree.mli *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Dict
+
+(* |name| -- type for applied occurrences with annotations *)
+type name = 
+  { x_name: ident;              (* Name of the reference *)
+    x_line: int;                (* Line number *)
+    mutable x_def: def option}  (* Definition in scope *)
+
+type expr = 
+    Constant of int
+  | Variable of name
+  | Monop of Keiko.op * expr
+  | Binop of Keiko.op * expr * expr
+  | Call of name * expr list
+
+type stmt =
+    Skip
+  | Seq of stmt list
+  | Assign of name * expr
+  | Return of expr
+  | IfStmt of expr * stmt * stmt
+  | WhileStmt of expr * stmt
+  | Print of expr
+  | Newline
+
+type block = Block of ident list * proc list * stmt
+
+and proc = Proc of name * ident list * block
+
+type program = Program of block
+
+
+(* seq -- neatly join a list of statements into a sequence *)
+val seq : stmt list -> stmt
+
+val makeName : ident -> int -> name
+
+(* |get_def| -- rerieve definition from name *)
+val get_def : name -> def
+
+(* |print_tree| -- pretty-print a tree *)
+val print_tree : out_channel -> program -> unit
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab4/Makefile	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,176 @@
+# lab4/Makefile
+
+all: ppc
+
+TOOLS = ../tools
+
+ppc: util.cmo mach.cmo optree.cmo dict.cmo tree.cmo lexer.cmo \
+		parser.cmo check.cmo target.cmo regs.cmo simp.cmo \
+		share.cmo jumpopt.cmo tran.cmo tgen.cmo main.cmo
+	ocamlc -g ../lib/common.cma $^ -o $@ 
+
+parser.ml parser.mli: parser.mly
+	ocamlyacc -v parser.mly
+
+lexer.ml: lexer.mll
+	ocamllex lexer.mll
+
+%.cmi: %.mli
+	ocamlc $(MLFLAGS) -c -g $<
+
+%.cmo: %.ml $(TOOLS)/nodexp
+	ocamlc $(MLFLAGS) -c -g -pp $(TOOLS)/nodexp $<
+
+MLFLAGS = -I ../lib
+
+$(TOOLS)/nodexp $(TOOLS)/pibake: $(TOOLS)/%: 
+	$(MAKE) -C $(TOOLS) $*
+
+test: force
+	@echo "Say..."
+	@echo "  'make test0' to compare assembly code"
+	@echo "  'make test1' to test using QEMU"
+	@echo "  'make test2' to test using a remote RPi"
+	@echo "  'make test3' to test using ECSLAB remotely"
+
+TESTSRC := $(shell ls test/*.p)
+OPT = -O2
+
+SCRIPT1 = -e '1,/^(\*\[\[/d' -e '/^]]\*)/q' -e p
+SCRIPT2 = -e '1,/^(\*<</d' -e '/^>>\*)/q' -e p
+
+ARMGCC = arm-linux-gnueabihf-gcc -marm -march=armv6
+
+ARCH := $(shell uname -m)
+QEMU-armv6l = env
+QEMU-armv7l = env
+QEMU := $(QEMU-$(ARCH))
+ifndef QEMU
+    QEMU := qemu-arm
+endif
+
+# test0 -- compile tests and diff object code
+test0 : $(TESTSRC:test/%.p=test0-%)
+
+test0-%: force
+	@echo "*** Test $*.p"
+	./ppc $(OPT) test/$*.p >b.s
+	-sed -n $(SCRIPT1) test/$*.p | diff -u -b - b.s
+	@echo
+
+# test1 -- compile tests and execute with QEMU
+test1 : $(TESTSRC:test/%.p=test1-%)
+
+test1-%: pas0.o force
+	@echo "*** Test $*.p"
+	./ppc $(OPT) test/$*.p >b.s
+	$(ARMGCC) b.s pas0.o -static -o b.out 
+	$(QEMU) ./b.out >b.test
+	sed -n $(SCRIPT2) test/$*.p | diff - b.test
+	@echo "*** Passed"; echo
+
+pas0.o: pas0.c
+	$(ARMGCC) -c $< -o $@
+
+# test2 -- compile tests and execute using remote or local RPi
+test2 : $(TESTSRC:test/%.p=test2-%)
+
+test2-%: $(TOOLS)/pibake force
+	@echo "*** Test $*.p"
+	./ppc $(OPT) test/$*.p >b.s
+	$(TOOLS)/pibake b.s >b.test
+	sed -n $(SCRIPT2) test/$*.p | diff - b.test
+	@echo "*** Passed"; echo
+
+# test3 -- ditto but using qemu on ecs.ox
+test3 : $(TESTSRC:test/%.p=test3-%)
+
+test3-%: $(TOOLS)/ecsx force
+	@echo "*** Test $*.p"
+	./ppc $(OPT) test/$*.p >b.s
+	$(TOOLS)/ecsx pas0.c fixup.s b.s >b.test
+	sed -n $(SCRIPT2) test/$*.p | diff - b.test
+	@echo "*** Passed"; echo
+
+promote: $(TESTSRC:test/%.p=promote-%)
+
+promote-%: force
+	./ppc $(OPT) test/$*.p >b.s
+	sed -f promote.sed test/$*.p >test/$*.new
+	mv test/$*.new test/$*.p
+
+force:
+
+MLGEN = parser.mli parser.ml lexer.ml
+
+ML = $(MLGEN) optree.ml tgen.ml tran.ml simp.ml share.ml jumpopt.ml \
+	check.ml check.mli dict.ml dict.mli lexer.mli \
+	mach.ml mach.mli main.ml optree.mli tgen.mli tree.ml \
+	tree.mli util.ml tran.mli target.mli target.ml \
+	simp.mli share.mli regs.mli regs.ml jumpopt.mli
+
+clean: force
+	rm -f *.cmi *.cmo *.o *.output
+	rm -f $(MLGEN)
+	rm -f ppc b.out b.s b.test
+
+depend: $(ML) $(TOOLS)/nodexp force
+	(sed '/^###/q' Makefile; echo; ocamldep -pp $(TOOLS)/nodexp $(ML)) >new
+	mv new Makefile
+
+CC = gcc
+
+###
+
+parser.cmi : tree.cmi optree.cmi dict.cmi
+parser.cmo : tree.cmi optree.cmi lexer.cmi dict.cmi parser.cmi
+parser.cmx : tree.cmx optree.cmx lexer.cmx dict.cmx parser.cmi
+lexer.cmo : util.cmo parser.cmi optree.cmi dict.cmi lexer.cmi
+lexer.cmx : util.cmx parser.cmx optree.cmx dict.cmx lexer.cmi
+optree.cmo : optree.cmi
+optree.cmx : optree.cmi
+tgen.cmo : tree.cmi tran.cmi target.cmi simp.cmi share.cmi regs.cmi \
+    optree.cmi mach.cmi lexer.cmi jumpopt.cmi dict.cmi tgen.cmi
+tgen.cmx : tree.cmx tran.cmx target.cmx simp.cmx share.cmx regs.cmx \
+    optree.cmx mach.cmx lexer.cmx jumpopt.cmx dict.cmx tgen.cmi
+tran.cmo : target.cmi regs.cmi optree.cmi tran.cmi
+tran.cmx : target.cmx regs.cmx optree.cmx tran.cmi
+simp.cmo : util.cmo optree.cmi simp.cmi
+simp.cmx : util.cmx optree.cmx simp.cmi
+share.cmo : regs.cmi optree.cmi mach.cmi share.cmi
+share.cmx : regs.cmx optree.cmx mach.cmx share.cmi
+jumpopt.cmo : util.cmo optree.cmi jumpopt.cmi
+jumpopt.cmx : util.cmx optree.cmx jumpopt.cmi
+check.cmo : util.cmo tree.cmi optree.cmi mach.cmi lexer.cmi dict.cmi \
+    check.cmi
+check.cmx : util.cmx tree.cmx optree.cmx mach.cmx lexer.cmx dict.cmx \
+    check.cmi
+check.cmi : tree.cmi
+dict.cmo : util.cmo optree.cmi mach.cmi dict.cmi
+dict.cmx : util.cmx optree.cmx mach.cmx dict.cmi
+dict.cmi : optree.cmi mach.cmi
+lexer.cmi : parser.cmi optree.cmi dict.cmi
+mach.cmo : mach.cmi
+mach.cmx : mach.cmi
+mach.cmi :
+main.cmo : tree.cmi tran.cmi tgen.cmi parser.cmi mach.cmi lexer.cmi \
+    check.cmi
+main.cmx : tree.cmx tran.cmx tgen.cmx parser.cmx mach.cmx lexer.cmx \
+    check.cmx
+optree.cmi :
+tgen.cmi : tree.cmi
+tree.cmo : optree.cmi dict.cmi tree.cmi
+tree.cmx : optree.cmx dict.cmx tree.cmi
+tree.cmi : optree.cmi dict.cmi
+util.cmo :
+util.cmx :
+tran.cmi : optree.cmi
+target.cmi : optree.cmi
+target.cmo : optree.cmi target.cmi
+target.cmx : optree.cmx target.cmi
+simp.cmi : optree.cmi
+share.cmi : optree.cmi
+regs.cmi : target.cmi
+regs.cmo : util.cmo target.cmi regs.cmi
+regs.cmx : util.cmx target.cmx regs.cmi
+jumpopt.cmi : optree.cmi
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lab4/check.ml	Thu Aug 16 13:59:09 2018 +0100
@@ -0,0 +1,623 @@
+(* lab4/check.ml *)
+(* Copyright (c) 2017 J. M. Spivey *)
+
+open Optree
+open Tree
+open Dict
+open Print