;;;; The Lisp CPU reader and evaluator ;;; global definitions (defparameter *memory* nil) (defparameter *free-mem-index* 0) (defparameter *symbol-table* nil) (defconstant *word-size-in-bits* 16) (defconstant *type-id-bits* 3) (defconstant *fixnum-bits* (- *word-size-in-bits* *type-id-bits*)) (defconstant *primitives* '#(+ - < > <= >= /= = * set quote setq defun progn get-time set-time set-led get-led while cons car cdr if)) ;;; position of the slots in a symbol structure (defconstant *symbol-value-ofs* 0) (defconstant *symbol-function-ofs* 1) (defconstant *symbol-name-ofs* 2) ;;; define higher type bits (defconstant *fixnum-type* (ash 0 *fixnum-bits*)) (defconstant *symbol-type* (ash 1 *fixnum-bits*)) (defconstant *list-type* (ash 2 *fixnum-bits*)) (defconstant *primitive-type* (ash 3 *fixnum-bits*)) (defconstant *array-type* (ash 4 *fixnum-bits*)) (defconstant *lambda-type* (ash 5 *fixnum-bits*)) (defconstant *nil-type* (ash 6 *fixnum-bits*)) (defconstant *type-mask* (ash 7 *fixnum-bits*)) (defconstant *fixnum-mask* (1- (ash 1 *fixnum-bits*))) ;;; the reader (defun get-primitive-word (symbol) "gets a primitive by symbol or *nil-type*, if not found" (let ((position (position symbol *primitives*))) (if position (logior position *primitive-type*) *nil-type*))) (defun alloc-mem (size) "allocates size words memory and returns the starting pointer to it" (let ((old-index *free-mem-index*)) (incf *free-mem-index* size) old-index)) (defun write-word (pointer value) "writes a word at pointer position" (setf (aref *memory* pointer) value)) (defun write-fixnum (pointer value) "writes a fixnum at pointer position" (write-word pointer (logior value *fixnum-type*))) (defun alloc-array (sequence) "allocates the memory for an array, stores the sequence in it and returns the pointer" (let* ((len (length sequence)) (pointer (alloc-mem (1+ len)))) (write-fixnum pointer len) (loop for i from 1 to len do (write-word (+ pointer i) (alloc-object (elt sequence (1- i))))) (logior pointer *array-type*))) (defun alloc-string (string) "allocates and stores a string and returns the pointer to it" (alloc-array (map 'list #'char-code string))) (defun symbol-set-value-list (pointer value) "sets the value list in the value slot of a symbol" (let ((type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *symbol-type*) (error "symbol pointer expected")) (write-word pointer value))) (defun symbol-get-value-list (pointer) "gets the value list of a symbol slot" (let ((type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *symbol-type*) (error "symbol pointer expected")) (let* ((pointer (read-word pointer)) (type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *list-type*) (error "list pointer expected")) pointer))) (defun symbol-set-value (pointer value) "sets the value at the car of the value list" (let ((pointer (logand (symbol-get-value-list pointer) *fixnum-mask*))) (write-word pointer value))) (defun symbol-prepend-value (pointer value) "prepends a new cons to the value list and sets the value" (let ((value-pointer (logand (symbol-get-value-list pointer) *fixnum-mask*))) (symbol-set-value-list pointer (mem-cons value value-pointer)))) (defun symbol-remove-value (pointer) "removes the first value of the value list" (let ((value-pointer (logand (symbol-get-value-list pointer) *fixnum-mask*))) (symbol-set-value-list pointer (mem-cdr value-pointer)))) (defun symbol-set-fun (pointer value) (let ((type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *symbol-type*) (error "symbol pointer expected")) (write-word (1+ pointer) value))) (defun symbol-set-name (pointer value) (let ((type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *symbol-type*) (error "symbol pointer expected")) (write-word (+ pointer 2) value))) (defun symbol-get-value (pointer) (let ((pointer (logand (symbol-get-value-list pointer) *fixnum-mask*))) (read-word pointer))) (defun symbol-get-fun (pointer) (let ((type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *symbol-type*) (error "symbol pointer expected")) (read-word (1+ pointer)))) (defun symbol-get-name (pointer) (let ((type (logand pointer *type-mask*)) (pointer (logand pointer *fixnum-mask*))) (when (/= type *symbol-type*) (error "symbol pointer expected")) (read-word (+ pointer 2)))) (defun alloc-symbol (symbol) "first searches by the name of the symbol, if the symbol is already created and returns this symbol, otherwise creates a symbol and returns it" (if (eq symbol nil) *nil-type* (let* ((symbol-string (string symbol)) (symbol-pointer (gethash symbol-string *symbol-table*))) (if symbol-pointer symbol-pointer (let ((symbol-pointer (logior (alloc-mem 3) *symbol-type*))) (symbol-set-value-list symbol-pointer (mem-cons *nil-type* *nil-type*)) (symbol-set-fun symbol-pointer (get-primitive-word symbol)) (symbol-set-name symbol-pointer (alloc-string (string symbol))) (setf (gethash symbol-string *symbol-table*) symbol-pointer) symbol-pointer))))) (defun alloc-atom (atom) "allocates and returns an atom (for fixnums no memory is allocated)" (cond ((integerp atom) (logior atom *fixnum-type*)) ((symbolp atom) (alloc-symbol atom)))) (defun get-fixnum (tagged-fixnum) "gets the fixnum value of a tagged value" (let ((type (logand tagged-fixnum *type-mask*)) (fixnum (logand tagged-fixnum *fixnum-mask*))) (when (/= type *fixnum-type*) (error "fixnum expected")) fixnum)) (defun mem-rplaca (cons-pointer value) "sets the car part of a cons structure" (let ((type (logand cons-pointer *type-mask*)) (pointer (logand cons-pointer *fixnum-mask*))) (when (/= type *list-type*) (error "list pointer expected")) (write-word pointer value)) cons-pointer) (defun mem-rplacd (cons-pointer value) "sets the cdr part of a cons structure" (let ((type (logand cons-pointer *type-mask*)) (pointer (logand cons-pointer *fixnum-mask*))) (when (/= type *list-type*) (error "list pointer expected")) (write-word (1+ pointer) value)) cons-pointer) (defun mem-car (cons-pointer) "gets the car part of a cons structure" (if (= cons-pointer *nil-type*) *nil-type* (let ((type (logand cons-pointer *type-mask*)) (pointer (logand cons-pointer *fixnum-mask*))) (when (/= type *list-type*) (error "list pointer expected")) (read-word pointer)))) (defun mem-cdr (cons-pointer) "gets the cdr part of a cons structure" (if (= cons-pointer *nil-type*) *nil-type* (let ((type (logand cons-pointer *type-mask*)) (pointer (logand cons-pointer *fixnum-mask*))) (when (/= type *list-type*) (error "list pointer expected")) (read-word (1+ pointer))))) (defun mem-cons (car cdr) "allocates a cons and saves the supplied car and cdr" (let ((cons-pointer (logior (alloc-mem 2) *list-type*))) (mem-rplaca cons-pointer car) (mem-rplacd cons-pointer cdr) cons-pointer)) (defun alloc-list (list) "allocates a list, saves the supplied list and returns a pointer to the start of the list" (let ((car (car list)) (cdr (cdr list))) (mem-cons (if (atom car) (alloc-atom car) (alloc-list car)) (if cdr (alloc-list cdr) *nil-type*)))) (defun alloc-object (object) "allocates memory for an object, saves the object and returns a pointer to it (or the object itself, if it is a fixnum)" (if (atom object) (alloc-atom object) (alloc-list object))) (defun init-mem (program-list) "clears the memory and initializes it with the binary representation of the supplied program-list" (setf *memory* (make-array 256 :element-type `(unsigned-byte ,*word-size-in-bits*) :initial-element 0)) (setf *free-mem-index* 0) (setf *symbol-table* (make-hash-table :test 'equal)) (alloc-list program-list)) (defun dump-mem () "raw memory dump" (let ((i 0)) (loop for line from 0 to 31 do (loop for column from 0 to 7 do (format t "~16,4,'0R " (aref *memory* i)) (incf i)) (when (>= i *free-mem-index*) (return)) (terpri)))) ;;; some print functions to print the content in the memory (defun read-word (pointer) (aref *memory* pointer)) (defun mem-print-list (pointer) (mem-print-object (mem-car pointer)) (let* ((cdr (mem-cdr pointer)) (type (logand cdr *type-mask*))) (when (/= type *nil-type*) (when (/= type *list-type*) (error "dotted list not supported")) (mem-print-list cdr)))) (defun mem-print-lambda (pointer) (princ "args: ") (mem-print-object (read-word (logand pointer *fixnum-mask*))) (terpri) (princ "fun: ") (mem-print-object (read-word (1+ (logand pointer *fixnum-mask*)))) (terpri)) (defun mem-print-symbol (pointer) (let* ((pointer (logand (symbol-get-name pointer) *fixnum-mask*)) (len (logand (read-word pointer) *fixnum-mask*)) (result "")) (loop for i from 1 to len do (setf result (concatenate 'string result (string (code-char (logand (read-word (+ pointer i)) *fixnum-mask*)))))) (format t "~X " result))) (defun mem-print-object (object) (let* ((type (logand object *type-mask*)) (fixnum (logand object *fixnum-mask*))) (cond ((= type *fixnum-type*) (format t "~D " fixnum)) ((= type *symbol-type*) (mem-print-symbol object)) ((= type *list-type*) (princ "(") (mem-print-list object) (princ ")")) ((= type *nil-type*) (format t "NIL "))))) ;;; the evaluator (defun mem-eval-object (object) "evaluates the object and returns the result" (let* ((type (logand object *type-mask*)) (fixnum (logand object *fixnum-mask*))) (cond ((= type *fixnum-type*) fixnum) ((= type *nil-type*) *nil-type*) ((= type *symbol-type*) (symbol-get-value object)) ((= type *list-type*) (mem-eval-list object))))) (defun prepend-args (defined-args current-args) (when (/= defined-args *nil-type*) (symbol-prepend-value (mem-car defined-args) (car current-args)) (prepend-args (mem-cdr defined-args) (cdr current-args)))) (defun remove-args (defined-args) (when (/= defined-args *nil-type*) (remove-args (mem-cdr defined-args)))) (defun eval-progn (list) "evaluates each element of the memory list and returns the last result" (if (= list *nil-type*) *nil-type* (let* ((car (mem-car list)) (cdr (mem-cdr list)) (object (mem-eval-object car))) (if (= cdr *nil-type*) object (eval-progn cdr))))) (defun execute-function (fun current-args) ; ;; TODO: error checking (args length) (let* ((type (logand fun *type-mask*)) (fun-pointer (logand fun *fixnum-mask*)) (defined-args (read-word fun-pointer)) (fun-list (read-word (1+ fun-pointer))) (current-args (eval-args current-args)) (result *nil-type*)) (when (/= type *lambda-type*) (error "function expected")) (prepend-args defined-args current-args) (setf result (eval-progn fun-list)) (remove-args defined-args) result)) (defun eval-args (args) "args: memory pointer to the argument list result: Lisp-list of memory objects (pointers and fixnums)" (if (= args *nil-type*) nil (let* ((car (mem-car args)) (cdr (mem-cdr args)) (cdr-type (logand cdr *type-mask*)) (object (mem-eval-object car))) (cond ((= cdr-type *nil-type*) (list object)) ((= cdr-type *list-type*) (append (list object) (eval-args cdr))) (t (error "unexpected cdr in function argument evaluation")))))) (defun mem-lambda (args function) "allocates two words for the lambda list and the function body for a function, init the function and return the pointer to the lambda" (let ((lambda-pointer (alloc-mem 2))) (write-word lambda-pointer args) (write-word (1+ lambda-pointer) function) (logior lambda-pointer *lambda-type*))) (defun execute-primitive (primitive args) "executes a primtive and returns the result" (let ((type (logand primitive *type-mask*)) (primitive (logand primitive *fixnum-mask*))) (when (/= type *primitive-type*) (error "primitive expected")) (let ((primitive (elt *primitives* primitive))) ;; primitives which doesn't evaluate the args (cond ((eq primitive 'quote) (when (= args *nil-type*) (error "quote expected at least 1 argument")) (let ((car (mem-car args)) (cdr (mem-cdr args))) (when (/= cdr *nil-type*) (error "too many arguments for quote")) car)) ((eq primitive 'setq) (when (= args *nil-type*) (error "setq expected 2 argument")) (let ((car (mem-car args)) (cdr (mem-cdr args))) (when (= cdr *nil-type*) (error "setq expected 2 arguments")) (when (/= (mem-cdr cdr) *nil-type*) (error "too many arguments for setq")) (symbol-set-value car (mem-eval-object (mem-car cdr))))) ((eq primitive 'defun) (when (= args *nil-type*) (error "defun expected at least 2 arguments")) (let ((function-symbol (mem-car args)) (lambda-cons (mem-cdr args))) (when (= lambda-cons *nil-type*) (error "defun expected 2 arguments")) (symbol-set-fun function-symbol (mem-lambda (mem-car lambda-cons) (mem-cdr lambda-cons))))) ((eq primitive 'while) (when (= args *nil-type*) (error "while expected at least 1 argument")) (let ((condition (mem-car args)) (body (mem-cdr args))) (loop while (/= (mem-eval-object condition) *nil-type*) do (eval-args body)) ; TODO: perhaps a special progn function *nil-type*)) ; TODO: perhaps returning the last result of the while body ((eq primitive 'if) (when (= args *nil-type*) (error "if expected at least 1 argument")) (let ((condition (mem-car args)) (body (mem-cdr args))) (if (/= (mem-eval-object condition) *nil-type*) (mem-eval-object (mem-car body)) (mem-eval-object (mem-car (mem-cdr body)))))) (t (let ((args (eval-args args))) ;; primitives which evaluates the args (cond ((eq primitive 'set-led) (when (/= (length args) 1) (error "set-led expected 1 argument")) (format t "set-led ~D~%" (car args)) *nil-type*) ((eq primitive 'car) (when (/= (length args) 1) (error "car expected 1 argument")) (mem-car (car args))) ((eq primitive 'cdr) (when (/= (length args) 1) (error "cdr expected 1 argument")) (mem-car (cdr args))) ((eq primitive 'nil) *nil-type*) ((eq primitive 'progn) (when (= (length args) 0) *nil-type*) (car (last args))) ((eq primitive 'cons) (when (/= (length args) 2) (error "cons expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (mem-cons arg1 arg2))) ((eq primitive 'set) (when (/= (length args) 2) (error "set expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (symbol-set-value arg1 arg2))) ((eq primitive '<) (when (/= (length args) 2) (error "< expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (if (< (get-fixnum arg1) (get-fixnum arg2)) 1 *nil-type*))) ((eq primitive '>) (when (/= (length args) 2) (error "> expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (if (> (get-fixnum arg1) (get-fixnum arg2)) 1 *nil-type*))) ((eq primitive '<=) (when (/= (length args) 2) (error "<= expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (if (<= (get-fixnum arg1) (get-fixnum arg2)) 1 *nil-type*))) ((eq primitive '>=) (when (/= (length args) 2) (error ">= expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (if (>= (get-fixnum arg1) (get-fixnum arg2)) 1 *nil-type*))) ((eq primitive '=) (when (/= (length args) 2) (error "= expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (if (= (get-fixnum arg1) (get-fixnum arg2)) 1 *nil-type*))) ((eq primitive '/=) (when (/= (length args) 2) (error "/= expected 2 arguments")) (let ((arg1 (elt args 0)) (arg2 (elt args 1))) (if (/= (get-fixnum arg1) (get-fixnum arg2)) 1 *nil-type*))) ((eq primitive '+) (reduce #'+ args)) ((eq primitive '-) (when (= (length args) 0) (error "- expected at leat 1 argument")) (reduce #'- args)) ((eq primitive '*) (reduce #'* args))))))))) (defun mem-eval-list (pointer) "evaluates memory list" (if (= pointer *nil-type*) *nil-type* (let* ((car (mem-car pointer)) (cdr (mem-cdr pointer))) (if (and (= car *nil-type*) (= cdr *nil-type*)) *nil-type* (progn (when (/= (logand car *symbol-type*) *symbol-type*) (error "evaluation list must start with a symbol")) (let* ((fun (symbol-get-fun car)) (fun-type (logand fun *type-mask*))) (cond ((= fun-type *lambda-type*) (execute-function fun cdr)) ((= fun-type *primitive-type*) (execute-primitive fun cdr)) (t (error "function slot must contain primitive or function"))))))))) ;;; some tests (terpri) (defparameter *program-list* (init-mem '(progn (setq test 0) (while (< test 10) (set-led test) (setq test (+ test 1)))))) (mem-print-object *program-list*) (terpri) (mem-print-object (mem-eval-object *program-list*)) (terpri) (defparameter *program-list* (init-mem '(progn (defun square (n) (if (> n 0) (cons (* n n) (square (- n 1))))) (square 4)))) (mem-print-object *program-list*) (terpri) (mem-print-object (mem-eval-object *program-list*)) ;;(dump-mem)