--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,7 @@
+syntax: glob
+
+scratch.lisp
+*.png
+*.svg
+docs/build
+prog.s
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,3 @@
+prog: prog.s runtime.c
+ gcc runtime.c prog.s -o prog
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,2 @@
+Going through <https://raw.githubusercontent.com/namin/inc/master/docs/tutorial.pdf>, but
+using Common Lisp as the implementation language and ARM64 as the target.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/iacc.lisp Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,156 @@
+;;;; Preamble -----------------------------------------------------------------
+(ql:quickload '(:losh :alexandria))
+
+(defpackage :iacc
+ (:use :cl)
+ (:export :compile-program
+ :fxadd1 :fxsub1 :fxzero?
+ :fixnum? :char? :null? boolean?
+ :char->fixnum :fixnum->char
+ )
+ (:shadow :fixnum :character :boolean))
+
+(in-package :iacc)
+
+;;;; Utils --------------------------------------------------------------------
+(defun todo ()
+ (error "Not implemented yet."))
+
+
+;;;; Types --------------------------------------------------------------------
+(deftype fixnum () '(signed-byte 62))
+(deftype character () 'cl:base-char)
+(deftype boolean () '(member :true :false))
+(deftype immediate () '(or fixnum character boolean null))
+(deftype primitive () '(satisfies primitivep))
+(deftype primitive-expression () '(cons primitive *))
+(deftype program () '(or immediate primitive-expression))
+
+
+;;;; Immediates ---------------------------------------------------------------
+;; Tagging scheme:
+;; xxxxxxxx…xxxxxx00 fixnum
+;; xxxxxxxx…xxxx1111 other immediate
+;;
+;; Immediates:
+;; xxxxxxxx…0000 1111 character
+;; xxxxxxxx…0010 1111 false
+;; xxxxxxxx…0110 1111 true
+;; xxxxxxxx…0011 1111 nil
+(defun immediate-rep (object)
+ (etypecase object
+ (fixnum (ash object 2))
+ (character (logior (ash (char-code object) 8) #b00001111))
+ ((eql :false) #b00101111)
+ ((eql :true) #b01101111)
+ (null #b00111111)))
+
+
+;;;; Basic Emitters -----------------------------------------------------------
+(defun emit (string &rest args)
+ (apply #'format *standard-output* string args)
+ (terpri *standard-output*))
+
+(defun emit-function-header (name)
+ (emit " .global ~A" name)
+ (emit " .type ~A, %function" name)
+ (emit "~A:" name))
+
+(defun emit-immediate (expr)
+ (emit " mov x0, ~D" (immediate-rep expr)))
+
+(defun emit-expr (expr)
+ (etypecase expr
+ (immediate (emit-immediate expr))
+ (primitive-expression (emit-primitive expr))))
+
+(defun emit-program (p)
+ (check-type p program)
+ (emit " .text")
+ (emit-function-header "scheme_entry")
+ (emit-expr p)
+ (emit " ret"))
+
+
+;;;; Primitives ---------------------------------------------------------------
+(defmacro define-primitive (name arglist &body body)
+ (let ((function-name (alexandria:symbolicate 'emit-primitive/ name)))
+ `(progn
+ (defun ,function-name ,arglist ,@body)
+ (setf (get ',name 'primitive) t
+ (get ',name 'arg-count) ,(length arglist)
+ (get ',name 'emitter) #',function-name)
+ ',function-name)))
+
+(defun primitivep (symbol)
+ (and (typep symbol 'symbol) (get symbol 'primitive)))
+
+(defun primitive-arg-count
+ (symbol) (get symbol 'arg-count))
+
+(defun primitive-emitter (symbol)
+ (get symbol 'emitter))
+
+(defun emit-primitive (expr)
+ (destructuring-bind (primitive &rest args) expr
+ (assert (= (primitive-arg-count primitive) (length args)) ()
+ "Bad primitive expression ~S, wanted ~D arg~:P but got ~D."
+ expr (primitive-arg-count primitive) (length args))
+ (apply (primitive-emitter primitive) args)))
+
+
+(define-primitive fxadd1 (arg)
+ (emit-expr arg)
+ (emit " add x0, x0, ~D ~30T// fxadd1" (immediate-rep 1)))
+
+(define-primitive char->fixnum (arg)
+ (emit-expr arg)
+ (emit " lsr x0, x0, #6 ~30T// char->fixnum"))
+
+(define-primitive fixnum->char (arg)
+ (emit-expr arg)
+ (emit " lsl x0, x0, #6 ~30T// fixnum->char")
+ (emit " orr x0, x0, 0x0F"))
+
+(define-primitive fxsub1 (arg)
+ (emit-expr arg)
+ (emit " sub x0, x0, ~D ~30T// fxsub1" (immediate-rep 1)))
+
+(define-primitive fxzero? (arg) (TODO))
+
+(define-primitive null? (arg) (TODO))
+
+(define-primitive fixnum? (arg)
+ (alexandria:with-gensyms (false)
+ ;; false #b00101111
+ ;; true #b01101111
+ (emit-expr arg)
+ (emit " and x0, x0, 0x03 ~30T// fixnum?") ; mask off all but the tag bits
+ (emit " cmp x0, 0x00") ; check the remaining tag bits
+ (emit " mov x0, ~D" #b00101111) ; start with false
+ (emit " bne ~A" false)
+ (emit " orr x0, x0, ~D" #b01000000) ; make it true
+ (emit "~A:" false)))
+
+(define-primitive boolean? (arg)
+ (alexandria:with-gensyms (false)
+ ;; false #b00101111
+ ;; true #b01101111
+ ;; ^ only bit 6 is different
+ (emit-expr arg)
+ (emit " bic x0, x0, ~D ~30T// boolean?" #b01000000) ; turn true into false
+ (emit " cmp x0, ~D" #b00101111) ; check for false
+ (emit " mov x0, ~D" #b00101111) ; false
+ (emit " bne ~A" false)
+ (emit " orr x0, x0, ~D" #b01000000) ; make it true
+ (emit "~A:" false)))
+
+(define-primitive char? (arg) (TODO))
+
+(define-primitive not (arg) (TODO))
+
+
+;;;; Toplevel -----------------------------------------------------------------
+(defun compile-program (program)
+ (with-open-file (*standard-output* "prog.s" :direction :output :if-exists :supersede)
+ (emit-program program)))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/runtime.c Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,47 @@
+#include <stdio.h>
+#include <stdint.h>
+
+// Bools
+#define bool_f 0x2F
+#define bool_t 0x6F
+
+// Fixnums
+#define fx_mask 0x03
+#define fx_tag 0x00
+#define fx_shift 2
+
+// Characters
+#define ch_mask 0xFF
+#define ch_tag 0x0F
+#define ch_shift 8
+
+// Nil
+#define nil 0x3F
+
+typedef uint64_t ptr;
+
+static void print_ptr(ptr x) {
+ if ((x & fx_mask) == fx_tag) {
+ printf("%ld", ((int64_t)x >> fx_shift));
+ } else if ((x & ch_mask) == ch_tag) {
+ printf("#\\%c", ((int)x >> ch_shift));
+ } else if (x == bool_f) {
+ printf("#f");
+ } else if (x == bool_t) {
+ printf("#t");
+ } else if (x == nil) {
+ printf("()");
+ } else {
+ printf("#<unknown #x%016lx>", x);
+ }
+
+ printf("\n");
+}
+
+int main(int argc, char** argv) {
+ print_ptr(scheme_entry());
+ return 0;
+}
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/sync Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+
+set -eu
+
+rsync -av ./ pine:src/iacc/ --exclude='.hg'
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+rlwrap sbcl --load "test.lisp" --eval "(1am:run)" --quit
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test.lisp Tue Mar 02 21:42:58 2021 -0500
@@ -0,0 +1,88 @@
+(ql:quickload '(:1am :losh :alexandria))
+
+(load (compile-file "iacc.lisp"))
+
+(defpackage :iacc/test
+ (:use :cl :losh)
+ (:use :iacc))
+
+(in-package :iacc/test)
+
+(defun run (program)
+ (iacc:compile-program program)
+ (losh:sh '("make" "prog"))
+ (string-trim '(#\newline) (losh:sh "./prog" :result-type 'string)))
+
+
+(defmacro define-test (name &body body)
+ `(1am:test ,(intern (concatenate 'string (symbol-name 'test-) (symbol-name name)))
+ (let ((*package* ,*package*))
+ ,@body)))
+
+(defmacro check (program expected)
+ `(1am:is (string= ,expected (run ,program))))
+
+(define-test fixnums
+ (check 0 "0")
+ (check 1 "1")
+ (check -1 "-1")
+ (check 10 "10")
+ (check -10 "-10")
+ (check 2736 "2736")
+ (check -2736 "-2736")
+ (check 536870911 "536870911")
+ (check -536870912 "-536870912"))
+
+(define-test booleans
+ (check :true "#t")
+ (check :false "#f"))
+
+(define-test null
+ (check nil "()"))
+
+(define-test characters
+ (check #\a "#\\a")
+ (check #\A "#\\A")
+ (check #\space "#\\ "))
+
+(define-test primitives/fxadd1
+ (check '(fxadd1 0) "1")
+ (check '(fxadd1 99) "100")
+ (check '(fxadd1 (fxadd1 202)) "204")
+ (check '(fxadd1 (fxadd1 -6)) "-4"))
+
+(define-test primitives/fxsub1
+ (check '(fxsub1 1) "0")
+ (check '(fxsub1 0) "-1")
+ (check '(fxsub1 99) "98")
+ (check '(fxsub1 (fxsub1 202)) "200")
+ (check '(fxsub1 (fxadd1 -6)) "-6"))
+
+(define-test primitives/char-fixnum-conversion
+ (check '(char->fixnum #\A) "65")
+ (check '(fixnum->char 65) "#\\A")
+ (check '(fixnum->char (fxadd1 (char->fixnum #\A))) "#\\B"))
+
+(define-test primitives/fixnum?
+ (check '(fixnum? 1) "#t")
+ (check '(fixnum? 0) "#t")
+ (check '(fixnum? -1) "#t")
+ (check '(fixnum? nil) "#f")
+ (check '(fixnum? :true) "#f")
+ (check '(fixnum? :false) "#f")
+ (check '(fixnum? #\A) "#f"))
+
+(define-test primitives/boolean?
+ (check '(boolean? 1) "#f")
+ (check '(boolean? 0) "#f")
+ (check '(boolean? -1) "#f")
+ (check '(boolean? nil) "#f")
+ (check '(boolean? :true) "#t")
+ (check '(boolean? :false) "#t")
+ (check '(boolean? #\A) "#f"))
+
+(define-test primitives/simple-combos
+ (check '(boolean? (fixnum? 1)) "#t")
+ (check '(boolean? (boolean? 1)) "#t")
+ (check '(fixnum? (char->fixnum #\A)) "#t"))
+