Add CL implementations of certain programs

.dir-locals.el

@@ -1,2 +1,3 @@
-((nil . ((indent-tabs-mode . t)
-		(tab-width . 8))))
+((nil . ((c-basic-offset . 8)
+	 (indent-tabs-mode . t)
+	 (tab-width . 8))))

.gitignore

@@ -1,2 +1,4 @@
 bin/*
 */*.o
+*/*.fasl
+*/*~

Ackermann/Ackermann.lisp

@@ -0,0 +1,18 @@
+;;;; This is a Common Lisp implementation of the Ackermann function
+
+(declaim (ftype (function (fixnum integer) integer) Ackermann))
+
+(defun Ackermann (m n)
+  (declare (type fixnum m) (type integer n))
+  (case m
+    ((0) (1+ n))
+    ((1) (+ 2 n))
+    ((2) (+ n n 3))
+    ((3) (+ (expt 2 (+ 3 n)) -3))
+    (t (let ((ir 1) (m-1 (- m 1)))
+	 (dotimes (i (1+ n) ir)
+	   (setf ir (Ackermann m-1 ir)))))))
+
+(defmacro Ackermann-test (m n)
+  (let ((i (gensym)) (j (gensym)))
+    `(dotimes (,i ,m nil) (dotimes (,j ,n) (format t "A(~d,~d)=~d~%" ,i ,j (Ackermann ,i ,j))))))

bf/bf2cl.lisp

@@ -0,0 +1,157 @@
+;;;; This is a simple BF-Common Lisp transpiler
+(defpackage :bf (:use :cl) (:export :tocl :tocl-string :tocl-file
+				    :tofile :tofile-string :tofile-file))
+(in-package :bf)
+
+(defgeneric token-tocl (token &key list pointer input output &allow-other-keys))
+
+(defstruct (operation)
+  (optype nil :type (or null symbol)))
+
+(defstruct (address)
+  (absolute nil :type boolean)
+  (offset 0 :type number))
+
+(defmethod token-tocl ((token address) &key list pointer &allow-other-keys)
+  (copy-list (if (address-absolute token)
+		 `(aref ,list ,(mod (address-offset token) 65536))
+		 (if (eql 0 (address-offset token))
+		     `(aref ,list ,pointer)
+		     `(aref ,list (mod (+ ,pointer ,(address-offset token)) 65536))))))
+
+(defstruct (op-inc
+	    (:include operation (optype 'inc :type symbol :read-only t)))
+  (position (make-address :absolute nil :offset 0) :type address)
+  (delta 0 :type fixnum))
+
+(defmethod token-tocl ((token op-inc) &key list pointer &allow-other-keys)
+  (copy-list `(setf ,(token-tocl (op-inc-position token) :list list :pointer pointer)
+		    (mod (+ ,(token-tocl (op-inc-position token) :list list :pointer pointer)
+			    ,(op-inc-delta token))
+			 256))))
+
+(defstruct (op-offset
+	    (:include operation (optype 'offset :type symbol :read-only t)))
+  (delta 0 :type fixnum))
+
+(defmethod token-tocl ((token op-offset) &key pointer &allow-other-keys)
+  (copy-list `(setf ,pointer (mod (+ ,pointer ,(op-offset-delta token)) 65536))))
+
+(defstruct (op-read
+	    (:include operation (optype 'read :type symbol :read-only t)))
+  (position (make-address :absolute nil :offset 0) :type address))
+
+(defmethod token-tocl ((token op-read) &key list pointer input &allow-other-keys)
+  (copy-list `(setf ,(token-tocl (op-read-position token) :list list :pointer pointer)
+		    (char-code (read-byte ,input nil #\Null)))))
+
+(defstruct (op-write
+	    (:include operation (optype 'write :type symbol :read-only t)))
+  (position (make-address :absolute nil :offset 0) :type address))
+
+(defmethod token-tocl ((token op-write) &key list pointer output &allow-other-keys)
+  (copy-list `(write-char
+	       (code-char ,(token-tocl (op-write-position token) :list list :pointer pointer))
+			  ,output)))
+
+(defstruct (op-loop
+	    (:include operation (optype 'loop :type symbol :read-only t)))
+  (position (make-address :absolute nil :offset 0) :type address)
+  (body nil :type list))
+
+(defmethod token-tocl ((token op-loop) &key list pointer input output &allow-other-keys)
+  (copy-list `(do () ((eql 0 ,(token-tocl (op-loop-position token)
+				   :list list
+				   :pointer pointer
+				   :input input
+				   :output output)))
+		(progn . ,(transpile (op-loop-body token) list pointer input output t)))))
+
+(defun tokenize-char (char &optional (stream *standard-input*) (recursive-p nil))
+  (case char
+    (#\+ (make-op-inc :delta 1))
+    (#\- (make-op-inc :delta -1))
+    (#\< (make-op-offset :delta -1))
+    (#\> (make-op-offset :delta 1))
+    (#\, (make-op-read))
+    (#\. (make-op-write))
+    (#\[ (make-op-loop :body (tokenize stream t)))
+    (#\] (if recursive-p t (error "unbalanced ]")))
+    (t nil)))
+
+(defun tokenize (stream &optional (recursive-p nil))
+  (do* ((c t (read-char stream nil))
+	(v nil (tokenize-char c stream recursive-p))
+	(l nil (if (typep v 'operation) (cons v l) l)))
+       ((or (null c) (eql t v)) l)))
+
+(defmacro deref-pos (absolute-p offset)
+  (let ((a (gensym)) (o (gensym)))
+    `(copy (let ((,a ,absolute-p) (,o ,offset))
+	     (cond
+	       (,a (mod ,o 65536))
+	       ((eql 0 ,o) 'pos)
+	       (t `(mod (+ pos ,,o) 65536)))))))
+
+(defun let-wrapper (body list pointer input output)
+  (declare (ignore input output))
+  (copy-list `(let ((,list (make-array 65536 :element-type 'fixnum :initial-element 0
+					   :adjustable nil))
+		    (,pointer 0))
+		(declare (type fixnum ,pointer))
+		,@body)))
+
+(defun transpile (elist list pointer input output &optional (recursive-p nil))
+  (let ((l (nreverse (cons nil (loop for i in elist collect (token-tocl i
+						    :list list
+						    :pointer pointer
+						    :input input
+						    :output output))))))
+    (if recursive-p l (let-wrapper l list pointer input output))))
+
+(defun combine-tokens (elist)
+  (do* ((r elist (cdr r)) (i (car r) (car r))) ((null i) elist)
+    (typecase i
+      (op-inc (loop for j on (cdr r) for e = (car j)
+		 while (and (typep e 'op-inc)
+			    (equalp (op-inc-position e) (op-inc-position i)))
+		 do (incf (op-inc-delta i) (op-inc-delta e))
+		 finally (setf (cdr r) j)))
+      (op-offset (loop for j on (cdr r) for e = (car j)
+		    while (typep e 'op-offset)
+		    do (incf (op-offset-delta i) (op-offset-delta e))
+		    finally (setf (cdr r) j)))
+      (op-loop (setf (op-loop-body i) (combine-tokens (op-loop-body i))))
+      (t i))))
+
+(defmacro optimize-token-list (elist)
+  `(combine-tokens ,elist))
+
+(defmacro toformlist (stream input output)
+  `(transpile (optimize-token-list (tokenize ,stream)) (gensym) (gensym) ,input ,output))
+
+(defmacro tocl (stream)
+  `(compile nil `(lambda (&optional (is *standard-input*) (os *standard-output*))
+		   (declare (ignorable is os) (optimize speed))
+		   ,(toformlist ,stream 'is 'os))))
+
+(defmacro tocl-string (string)
+  (let ((str (gensym)))
+    `(with-input-from-string (,str ,string) (tocl ,str))))
+
+(defmacro tocl-file (file)
+  (let ((str (gensym)))
+    `(with-open-file (,str ,file) (tocl ,str))))
+
+(defmacro tofile (istream ostream)
+  (let ((is (gensym)))
+    `(let ((,is ,istream))
+       (prin1 (toformlist ,is '*standard-input* '*standard-output*) ,ostream))))
+
+(defmacro tofile-string (string ostream)
+  (let ((str (gensym)))
+    `(with-input-from-string (,str ,string) (tofile ,str ,ostream))))
+
+(defmacro tofile-file (file ostream)
+  (let ((str (gensym)))
+    `(with-open-file (,str ,file) (tofile ,str ,ostream))))

build.pl

@@ -65,4 +65,4 @@ if (! @ARGV) {
 	foreach my $i (keys %defs) {
 		compile $i;
 	}
-}
+}