From c9c872e7c5cf568076e3b8cc06b239f72cac41ea Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Fri, 5 Oct 2018 20:19:12 +0200 Subject: [PATCH] Fix 8748 assembler to compile with Maclisp. --- build/lisp.tcl | 6 ++++ src/lmio1/{as8748.38 => as8748.39} | 53 ++++++++++++++++++++---------- 2 files changed, 42 insertions(+), 17 deletions(-) rename src/lmio1/{as8748.38 => as8748.39} (93%) diff --git a/build/lisp.tcl b/build/lisp.tcl index d8c2c5c0..bd6f955c 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -1124,3 +1124,9 @@ respond ":" "t\r" respond ":" "t\r" respond "\n" ":vk\r" respond "*" ":kill\r" + +# AS8748 +respond "*" ":complr\r" +respond "_" "lmio1;as8748\r" +respond "_" "\032" +type ":kill\r" diff --git a/src/lmio1/as8748.38 b/src/lmio1/as8748.39 similarity index 93% rename from src/lmio1/as8748.38 rename to src/lmio1/as8748.39 index 73daba6d..c42cbddf 100644 --- a/src/lmio1/as8748.38 +++ b/src/lmio1/as8748.39 @@ -2,6 +2,11 @@ ;;; Assemble for 8x48 series of microprocessors +;;; Modified 2018-10-05 by EJS to work on MacLisp as well as LISPM + +(eval-when (compile) + (load '((lisp) umlmac))) + (declare (special as-pc as-labels as-assignments as-pass as-must-be-assigned as-form as-code as-known-new-pc)) @@ -35,6 +40,16 @@ (putprop program program 'USER:LOCATION) program) +(defmacro as-make-array (size) + #+LISPM `(make-array ,size ':TYPE 'ART-Q) + #+(or Maclisp Franz) `(*ARRAY NIL T ,SIZE) + #+NIL `(make-vector ,size)) + +(defmacro as-set-array (val array idx) + #+LISPM `(aset ,val array ,idx) + #+(or Maclisp Franz) `(store (arraycall t array ,idx) ,val) + #+NIL `(vset array ,idx ,val)) + (defun as-convert-to-prom-image (code) (let ((pc -1) (high -1) @@ -47,14 +62,14 @@ (t (setq pc (1+ pc)))) (and (> pc high) (setq high pc))) - (setq array (make-array nil 'art-q (1+ high))) + (setq array (as-make-array (1+ high))) (fillarray array '(0)) (setq pc -1) (dolist (elt code) (cond ((and (listp elt) (eq (car elt) '=)) (setq pc (cadr elt))) - (t (aset elt array pc) + (t (as-set-array elt array pc) (setq pc (1+ pc))))) array)) @@ -63,6 +78,12 @@ (and (eq as-pass 'PASS-2) (setq as-code (cons (logand value 377) as-code)))) +(defun as-error (error-string &rest args) + (lexpr-funcall #'format t error-string args) + (format t " while assembling ~A~%" as-form) + (and as-known-new-pc (setq as-pc as-known-new-pc)) + (*throw 'AS-ERROR nil)) + (defun as-compile-form (as-form) (setq as-known-new-pc nil) (*catch 'AS-ERROR @@ -80,7 +101,7 @@ ((listp as-form) (let ((dispatch (get (car as-form) 'AS-DISPATCH))) (cond (dispatch (funcall dispatch as-form)) - (( (length as-form) 1) + ((not (=(length as-form) 1)) (as-error "Undefined operation in form ~A" as-form)) (t (as-generate-8-bits (as-hack-expression (car as-form))))))) ((numberp as-form) @@ -95,29 +116,27 @@ (putprop '@R0 '(REGISTER-INDIRECT 0) 'AS-REGISTER) (putprop '@R1 '(REGISTER-INDIRECT 1) 'AS-REGISTER) +(defmacro as-return (v1 v2) + #+LISPM `(return ,v1 ,v2) + #-LISPM `(return (values ,v1 ,v2))) + (defun as-parse-arg (arg) (prog (tem) - (cond ((numberp arg) (return arg 'ADDRESS)) + (cond ((numberp arg) (as-return arg 'ADDRESS)) ((symbolp arg) (cond ((setq tem (get arg 'AS-REGISTER)) - (return (cadr tem) (car tem))) - ((eq arg 'A) (return 'A 'A)) - ((eq arg 'T) (return 'T 'T)) - ((eq arg 'PSW) (return 'PSW 'PSW)) - (t (return (as-hack-expression arg) 'ADDRESS)))) + (as-return (cadr tem) (car tem))) + ((eq arg 'A) (as-return 'A 'A)) + ((eq arg 'T) (as-return 'T 'T)) + ((eq arg 'PSW) (as-return 'PSW 'PSW)) + (t (as-return (as-hack-expression arg) 'ADDRESS)))) ((listp arg) (cond ((eq (car arg) '/#) (setq as-known-new-pc (+ as-pc 2)) - (return (as-hack-expression (cadr arg)) 'IMMEDIATE)) - (t (return (as-hack-expression arg) 'ADDRESS)))) + (as-return (as-hack-expression (cadr arg)) 'IMMEDIATE)) + (t (as-return (as-hack-expression arg) 'ADDRESS)))) (t (as-error "~A is illegal arg" arg))))) -(defun as-error (error-string &rest args) - (lexpr-funcall #'format t error-string args) - (format t " while assembling ~A~%" as-form) - (and as-known-new-pc (setq as-pc as-known-new-pc)) - (*throw 'AS-ERROR nil)) - ;;; "Pseduo-ops" (defun as-set-pc (form &aux (old-pc as-pc))