OpenCores
URL https://opencores.org/ocsvn/igor/igor/trunk

Subversion Repositories igor

Compare Revisions

  • This comparison shows the changes necessary to convert path 
    /igor/trunk
    from Rev 2 to Rev 3
    ↔ Reverse comparison
  •

Rev 2 → Rev 3

/processor/mc/README
0,0 → 1,5
The files contained in this directory is the multicycle prosessor.
 
The toplevel instanciates the processor, the bus interface, some synchronizers for the control lines and the address decoding logic.
 
The processor top-level is leval.vhd, and from there I guess it's possible do deduce where all the other files fit in.
/microprogram_assembler/simplemc.lisp
0,0 → 1,30
(in-package #:mcasm)
 
(defun write-microprogram (&key (output-format :simulator))
(with-assembly ("/tmp/microcode" :output-format output-format)
(%set-type-imm $zero +type-int+)
(%set-datum-imm $zero 0)
(%set-type-imm $one +type-int+)
(%set-datum-imm $one 1)
(%set-type-imm $two +type-int+)
(%set-datum-imm $two 2)
 
(%set-type-imm $tmp1 +type-int+)
(%set-type-imm $tmp2 +type-int+)
 
;; do something (here, an %add) #x42 times:
(%set-datum-imm $tmp1 #x42)
(%set-datum-imm $tmp2 0)
:loop1
(%add $tmp2 $one)
(%decr $tmp1)
(branchimm-false :loop1)
 
;; do something else (here, a %sub) #x4 times:
(%set-datum-imm $tmp1 #x4)
:loop2
(%sub $tmp2 $one)
(%decr $tmp1)
(branchimm-false :loop2)
 
(%halt)))
/microprogram_assembler/bootprogram.lisp
0,0 → 1,1899
;;;
(in-package #:sexptomem)
 
(sexp-to-memory*
(%nil
%t
%if
%quote
%lambda
%progn
%cons
%car
%cdr
%eval
%apply
%type
%make-array
%array-size
%array-get
%array-set
%make-symbol
%symbol-to-string
%char-to-int
%int-to-char
%get-char
%put-char
%num-devices
%device-type
%set-address
%get-address
%error
%add
%sub
%mul
%div
%bitwise-and
%bitwise-or
%bitwise-not
%bitwise-shift
%current-environment
%make-eval-state
%eval-partial
%define
%undefine
%eq?
%num-eq?
%char-eq?
%less-than?
%mod
%set!
%set-car!
%set-cdr!
%function-data
%builtin-name
%device-size
%device-status
 
xxxaa
xxxab
xxxac
xxxad
xxxae
xxxaf
xxxag
xxxah
xxxai
xxxaj
xxxak
%symbol-table
 
%phase-eval
%phase-eval-args
%phase-apply
%phase-eval-if
%phase-initial
%phase-env-lookup
%phase-env-lookup-local
%phase-apply-function
%phase-bind-args
%phase-eval-progn
%phase-eval-args-top
%phase-eval-args-cdr
%phase-eval-args-cons
%phase-eval-symbol
%phase-set!
 
xxx3F
 
%timeout
%err-invalid-phase
%err-unbound-symbol
%err-invalid-param-list
%err-too-few-args
%err-too-many-args
%err-invalid-state
%err-invalid-arg-list
%err-type-error
%err-not-a-list
%err-not-a-function
%err-invalid-function
%err-malformed-form
%err-invalid-builtin
%err-invalid-array-index
%err-invalid-env
%err-not-a-pair
%err-division-by-zero
%err-overflow
)
 
(%progn
(%progn ; Define types
(%define '+type-none+ #x0)
(%define '+type-int+ #x1)
(%define '+type-float+ #x3)
(%define '+type-cons+ #x4)
(%define '+type-snoc+ #x5)
(%define '+type-ptr+ #x6)
(%define '+type-array+ #x7)
(%define '+type-nil+ #x8)
(%define '+type-t+ #x9)
(%define '+type-char+ #xA)
(%define '+type-symbol+ #xB)
(%define '+type-function+ #xC)
(%define '+type-builtin+ #xD)
)
(%define 'current-input 2)
(%define 'current-output 2)
 
(%define '*print-base* 16)
(%define '1+ (%lambda 1+ (x)
(%add 1 x)))
(%define '1- (%lambda 1- (x) (%sub x 1)))
 
(%define 'map (%lambda map (fn list)
(%if list
(%cons (fn (%car list))
(map fn (%cdr list)))
%nil)))
(%define 'map-short (%lambda map-short (fn list)
(%if list
(%cons (fn (%car list))
(map fn (%cdr list)))
%nil)))
 
(%define 'list (%lambda list list list))
(%define 'char-upper (%lambda char-upper (char)
(let ((n (%char-to-int char)))
(%if (%less-than? (1- (%char-to-int #\a)) n)
(%if (%less-than? n (1+ (%char-to-int #\z)))
(%int-to-char (%sub n 32))
char)
char))))
(%define 'make-string-stream (%lambda make-string-stream (str pos)
(%lambda string-stream (cmd)
(%if (%eq? cmd 'get-char)
(%if (%less-than? (1- (%array-size str)) pos)
'eos
(%progn
(%set! 'pos (1+ pos))
(%array-get str (1- pos))))
(%if (%eq? cmd 'peek-char)
(%if (%less-than? (1- (%array-size str)) pos)
'eos
(%array-get str pos))
%nil)))))
 
(%define 'make-device-input-stream (%lambda make-device-input-stream (device-number)
(let ((chpeek %nil))
(%lambda device-input-stream (cmd)
(%if (%eq? cmd 'get-char)
(let ((thech (%if chpeek
(let ((ch chpeek))
(%set! 'chpeek %nil)
ch)
(%get-char device-number))))
(%if (or2 (%num-eq? device-number 2) (%num-eq? device-number 0))
(%put-char current-output thech)
%nil)
thech)
(%if (%eq? cmd 'peek-char)
(%if chpeek
chpeek
(%set! 'chpeek (%get-char device-number)))
%nil))))))
 
 
 
 
(%define
'stream-wrapper-narwhal
(%lambda stream-wrapper-narwhal (stream)
(let ((chpeek %nil))
(%lambda input-stream (cmd)
(%if (%eq? cmd 'get-char)
(%if chpeek
(let ((chkeep chpeek))
(%set! 'chpeek %nil)
chkeep)
(stream 'get-char))
(%if (%eq? cmd 'peek-char)
(%if chpeek
chpeek
(%set! 'chpeek (stream 'get-char)))
(%error 'I-<3-YOU-STREAM-WRAPPER)))))))
 
;Code for reading the filesystem
;Filetable first, each entry has [in use, filename, start-block, length]
;Then comes one word per block, which is rather hilarious usage of space...
;... "meta-info" about blocks, we'll call it. suuure.
;Then comes the blocks. Each block is some size. A block has a pointer to
;the next block that follows it.
;The fileinfo (file identifier) passed around.
(%define '+fileinfo-num-fields+ 6)
(%define '+fileinfo-name+ 0)
(%define '+fileinfo-tableindex+ 1)
(%define '+fileinfo-block+ 2)
(%define '+fileinfo-block-pos+ 3)
(%define '+fileinfo-current-pos+ 4)
(%define '+fileinfo-size+ 5)
;The metadata structure.
(%define '+metadata-pos+ 0)
(%define '+metadata-size+ 16)
(%define '+metadata-num-blocks+ 0)
(%define '+metadata-free-blocks+ 1)
(%define '+metadata-blocksize+ 2)
(%define '+metadata-block-pos+ 3)
(%define '+metadata-ft-num-rows+ 4) ;number of filetable rows
(%define '+metadata-ft-free-rows+ 5) ;number of free rows
(%define '+metadata-ft-rowsize+ 6) ;size of a filetable row
(%define '+metadata-ft-pos+ 7) ;position of filetable (absolute address)
 
;The filetable structure and various values
(%define '+filetable-pos+ 16)
(%define '+filetable-field-size+ 16)
(%define '+filetable-num-rows+ 2)
(%define '+filetable-size+ 32)
(%define '+filetable-not-in-use-marker+ 0)
(%define '+filetable-field-in-use+ 0)
(%define '+filetable-field-filename+ 1)
(%define '+filetable-field-start-block+ 14)
(%define '+filetable-field-filesize+ 15)
(%define '+filename-size+ 13)
;The blocktale structure
(%define '+blocktable-pos+ 48)
(%define '+blocktable-size+ 8)
 
;Various defines partaining to blocks
(%define '+block-section-pos+ 56)
(%define '+block-size+ 8)
(%define '+num-blocks+ 8)
 
 
;The device used for storage
(%define '+storage-dev+ 1)
;get the ith entry from the filetable, put it in an array
(defun filetable-entry (index)
(get-string
(address-of-entry index)
(metadata +metadata-ft-rowsize+)))
(%define '+file-null-char+ 4)
;should've had array-append...
(defun count-non-null* (s pos num)
(%if (%num-eq?
(%array-size s)
pos)
num
(%if (%num-eq?
+file-null-char+
(%char-to-int (%array-get s pos)))
(count-non-null* s (1+ pos) num)
(count-non-null* s (1+ pos) (1+ num)))))
(defun count-non-null (s)
(count-non-null* s 0 0))
 
 
 
(defun strip-null (s)
(array-resize s (count-non-null s)))
 
 
 
 
(defun array-resize* (new arr size pos)
(%if (%num-eq?
size
pos)
new
(%progn
(%array-set new pos (%array-get arr pos))
(array-resize* new arr size (1+ pos)))))
 
(defun array-resize (arr size)
(let ((new (%make-array size %nil)))
(array-resize* new arr size 0)))
 
 
 
 
(defun str-eq?* (f1 f2 pos)
(%if
(%num-eq? (%array-size f1) pos)
%t
(%if (%char-eq?
(%array-get f1 pos)
(%array-get f2 pos))
(str-eq?* f1 f2 (1+ pos))
%nil)))
(defun str-eq? (f1 f2)
(%if (%num-eq? (%array-size f1) (%array-size f2))
(str-eq?* f1 f2 0)
%nil))
 
;slice of a part of an array of chars [tested ok...]
(%define
'string-slice*
(%lambda
string-slice* (str slice stringpos pos len)
(%if (%num-eq? pos len)
slice
(%progn
(%array-set slice pos (%array-get str stringpos))
(string-slice* str slice (1+ stringpos) (1+ pos) len)))))
(%define
'string-slice
(%lambda
string-slice (str start len)
(let ((slice (%make-array len %nil)))
(string-slice* str slice start 0 len))))
;get the filename of an entry in the filetable
(%define
'filetable-entry-filename
(%lambda filetable-entry-filename (filetable-entry)
(string-slice
filetable-entry
+filetable-field-filename+
+filename-size+)))
(%define
'filetable-entry-block
(%lambda filetable-entry-block (filetable-entry)
(%char-to-int
(%array-get filetable-entry +filetable-field-start-block+))))
 
(%define
'filetable-entry-size
(%lambda filetable-entry-size (filetable-entry)
(%char-to-int
(%array-get filetable-entry +filetable-field-filesize+))))
 
(defun filetable-entry-in-use (entry)
(%if (%num-eq?
(%char-to-int (%array-get entry +filetable-field-in-use+))
0)
%nil
%T))
;Get the starting block of the file at index in filetable
(%define
'filetable-start-block
(%lambda filetable-start-block (index)
(%progn
(%set-address +storage-dev+ 0)
(%char-to-int (%get-char (%add
(%mul +filetable-field-size+ index)
+filetable-field-start-block+))))))
;Get the size of the file at index in the filetable
(%define
'filetable-filesize
(%lambda filetable-filesize
(%set-address +storage-dev+ 0)
(%char-to-int (%get-char (%add
(%mul +filetable-field-size+ index)
+filetable-field-filesize+)))))
 
;put length chars from starting-position into an array of length size
(defun get-string* (str len pos)
(%if (%num-eq? pos len)
str
(%progn
(%array-set str pos (%get-char +storage-dev+))
(get-string* str len (1+ pos)))))
 
 
(defun get-string (start-pos length)
(let ((string (%make-array length %nil)))
(%set-address +storage-dev+ start-pos)
(get-string* string length 0)))
 
(defun put-string* (src len pos)
(%if (%num-eq? pos len)
src
(%progn
(%put-char +storage-dev+ (%array-get src pos))
(put-string* src len (1+ pos)))))
 
(defun put-string (dst string)
(%set-address +storage-dev+ dst)
(put-string* string (%array-size string) 0))
 
;iterate file-table, find matching filename and return the fileinfo-entry, used by streams
(defun open-file* (filename file-info index)
(%if (%num-eq?
(metadata +metadata-ft-num-rows+)
index)
(display "No such file or filename. IGOR is not happy, making him work this much...")
(let ((entry (filetable-entry index))) ;get ith entry in filetable
(%if (filetable-entry-in-use entry)
(let ((entry-filename (strip-null (filetable-entry-filename entry)))) ;store filename
(%if (str-eq? entry-filename filename) ;compare filenames, if equal:
(%progn
;create a file-info structure
(%array-set file-info +fileinfo-name+ entry-filename)
(%array-set file-info +fileinfo-block+ (filetable-entry-block entry))
(%array-set file-info +fileinfo-size+ (filetable-entry-size entry))
file-info)
;filename mismatch, next entry please
(open-file* filename file-info (1+ index))))
(open-file* filename file-info (1+ index)))))) ;entry not in use, next.
 
(defun open-file (filename)
(let ((file-info (%make-array +fileinfo-num-fields+ 0)))
(open-file* filename file-info 0)))
 
 
(defun filetable-get-offset (filename index)
(let ((current-filename (get-string
(%add
+filetable-field-fieldname+ (%mul
index
+filetable-field-size+))
+filename-size+)))))
 
 
 
(defun file-address (file-info)
(%add
(address-of-block (%array-get file-info +fileinfo-block+))
(%array-get file-info +fileinfo-block-pos+)))
 
(%define
'make-fisk-stream
(%lambda make-fisk-stream (open-fisk-dings)
(stream-wrapper-narwhal
(%lambda fisk-stream (cmd)
(%if (%eq? cmd 'get-char)
(file-get-char open-fisk-dings))))))
(%define
'file-eof?
(%lambda file-eof? (file-info)
(%if (%eq?
(%array-get file-info +fileinfo-current-pos+)
(%array-get file-info +fileinfo-size+))
%t
%nil)))
(%define
'file-get-char
(%lambda file-get-char (file-info)
(%if (file-eof? file-info)
(%error 'EOF)
(let ((ch (file-read-char file-info)))
 
(file-increment-pos file-info)
ch))))
 
(%define
'file-read-char
(%lambda file-read-char (file-info)
(%progn
(%set-address +storage-dev+ (file-address file-info))
(%get-char +storage-dev+))))
(%define
'file-increment-pos
(%lambda file-increment-pos (file-info)
(%if (file-eof? file-info) ;if we're at the end of the file...
%nil ;...don't increment
(%progn
(%array-set ;else, increment the current-position by 1
file-info
+fileinfo-current-pos+
(1+ (%array-get file-info +fileinfo-current-pos+)))
(%if (end-of-block file-info) ;if end of block...
(%progn
(%array-set
file-info
+fileinfo-block+
(file-next-block
(%array-get file-info +fileinfo-block+))) ;find the next block and set
(%array-set
file-info
+fileinfo-block-pos+
0)) ;and set the current inter-block-position to 0
(%array-set ;else, we're not at the end of the block.
file-info
+fileinfo-block-pos+
(1+ (%array-get file-info +fileinfo-block-pos+)))))))) ; simply update current block
 
(%define
'end-of-block
(%lambda end-of-block (file-info)
(%if (%num-eq?
(%array-get file-info +fileinfo-block-pos+)
(%sub +block-size+ 2))
%t
%nil);not end of block
))
 
 
(%define
'file-next-block
(%lambda file-next-block (current-block)
(%progn
(%set-address
+storage-dev+
(%add
(address-of-block current-block)
(1- +block-size+)))
(%char-to-int (%get-char +storage-dev+)))))
 
(defun address-of-block (bloc)
(%add
+block-section-pos+
(%mul +block-size+ bloc)))
 
 
(defun list-files* (index)
(%if (%num-eq?
index
+filetable-num-rows+)
%T
(let ((entry (filetable-entry index)))
(%if (filetable-entry-in-use entry)
(%progn
(display (strip-null (filetable-entry-filename entry)))
(newline)
(list-files* (1+ index)))
(list-files* (1+ index))))))
 
(defun list-files ()
(list-files* 0))
 
 
(defun metadata (num)
(%set-address +storage-dev+ (%add +metadata-pos+ num))
(%char-to-int (%get-char +storage-dev+)))
;Code for writing to the filesystem is below.
(defun create-file (filename)
(let ((entry (filetable-free-entry)))
(let ((addr (address-of-entry entry)))
(put-char-at-addr addr (%int-to-char 1))
(put-string (%add
addr
+filetable-field-filename+)
filename)
(put-char-at-addr (%add
addr
+filetable-field-start-block+)
(%int-to-char (find-free-block)))
(put-char-at-addr (%add
addr
+filetable-field-filesize+)
(%int-to-char 0))))
(open-file filename))
(defun put-char-at-addr (addr char)
(%set-address +storage-dev+ addr)
(%put-char +storage-dev+ char))
(defun address-of-entry (entry)
(%add
(%mul
entry
(metadata +metadata-ft-rowsize+))
(metadata +metadata-ft-pos+)))
;DOES: Attempts to find a free entry in the file table.
;THROWS: 'filetable-full
(defun filetable-free-entry ()
(%if (%num-eq? (metadata +metadata-ft-free-rows+) 0)
(%error 'filetable-meta-full)
(filetable-free-entry* 0)))
(defun filetable-free-entry* (index)
(%if
(%num-eq?
index
(metadata +metadata-ft-num-rows+))
(%error 'filetable-full)
(%if ;if this entry is not in use
(%num-eq?
(%char-to-int (%array-get (filetable-entry index) +filetable-field-in-use+))
+filetable-not-in-use-marker+);...eh
index ;return the index.
(filetable-free-entry* (1+ index)))))
 
(defun find-free-block* (index)
(%if
(%num-eq?
(metadata +metadata-num-blocks+)
index)
%nil
(%progn
(%set-address +storage-dev+ (%add +blocktable-pos+ index))
(%if
(%num-eq?
(%char-to-int (%get-char +storage-dev+))
0)
index
(find-free-block* (1+ index))))))
 
(defun find-free-block ()
(%if
(%num-eq?
(metadata +metadata-free-blocks+)
0)
(%error 'no-free-blocks)
(find-free-block* 0)))
 
(defun set-block-unfree '()
(display "cannot unfree what has been unseen"))
(defun set-block-free '()
(display "setting a block free!"))
 
 
(defun write-filetable-entry (fileinfo)
(let ((entry (filetable-find-free-entry)))))
 
(%define 'string=-rec (%lambda string=-rec (i s1 s2)
(%if (%num-eq? i (%array-size s1))
%t
(%if (%char-eq? (%array-get s1 i)
(%array-get s2 i))
(string=-rec (1+ i) s1 s2)
%nil))))
 
(%define 'string=? (%lambda string=? (s1 s2)
(%if (%num-eq? (%array-size s1) (%array-size s2))
(string=-rec 0 s1 s2)
%nil)))
(%define 'symbol-exists?-rec (%lambda symbol-exists?-rec (symbol-table str)
(%if symbol-table
(%if (string=? (%symbol-to-string (%car symbol-table)) str)
(%car symbol-table)
(symbol-exists?-rec (%cdr symbol-table) str))
%nil)))
;; Check if a symbol is interned
(%define 'symbol-exists? (%lambda symbol-exists? (str)
(symbol-exists?-rec %symbol-table str)))
;; Intern a symbol, if it is already intered, just return the symbol
(%define 'intern (%lambda intern (str)
(let ((sym (symbol-exists? str)))
(%if sym sym
(let ((sym (%make-symbol str)))
(%set! '%symbol-table (%cons sym %symbol-table))
sym)))))
 
(%define
'intern-char-hash
(%lambda
intern-char-hash (ch)
(%bitwise-and (%char-to-int ch) 7)))
 
(%define
'intern-make-node
(%lambda
intern-make-node ()
(%cons nil (%make-array 8 nil))))
 
(%define
'intern-get-node
(%lambda
intern-get-node (tab hash)
(%array-get
(%if (%array-get tab hash)
tab
(%array-set tab hash (intern-make-node)))
hash)))
 
(%define
'intern-get-sym-in-list
(%lambda
intern-get-sym-in-list (str list)
(%if list
(%if (string=? (%symbol-to-string (%car list)) str)
(%car list)
(intern-get-sym-in-list str (%cdr list)))
nil)))
 
(%define
'intern-rec
(%lambda
intern-rec (str i tree existing-symbol)
(%if (%num-eq? i (%array-size str))
(let ((sym (intern-get-sym-in-list str (%car tree))))
(%if sym sym
(%car (%set-car! tree (%cons (%if existing-symbol
existing-symbol
(%make-symbol str))
(%car tree))))))
(intern-rec
str
(%add i 1)
(intern-get-node (%cdr tree) (intern-char-hash (%array-get str i)))
existing-symbol))))
 
(%define 'symbol-tree (intern-make-node))
 
(%define
'intern-foo
(%lambda
intern (str)
(intern-rec str 0 symbol-tree nil)))
 
(%define
'intern-symbols
(%lambda
intern-symbols (list)
(%if list
(%progn (intern-rec (%symbol-to-string (%car list)) 0 symbol-tree (%car list))
(intern-symbols (%cdr list)))
nil)))
 
 
;; See if an element member of a list
(%define 'member (%lambda member (elem list test)
(%if list
(%if (test (%car list) elem)
%t
(member elem (%cdr list) test))
%nil)))
 
;; Or functions
;; XXX: Special form
(%define 'or2 (%lambda or2 (a b) ; XXX: Special forms
(%if a a b)))
(%define 'or3 (%lambda or3 (a b c)
(or2 a (or2 b c))))
 
(%define 'digits (%%list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(%define 'digits-hex (%cons #\a (%cons #\b (%cons #\c (%cons #\d (%cons #\e (%cons #\f
(%cons #\A (%cons #\B (%cons #\C (%cons #\D (%cons #\E (%cons #\F digits)))))))))))))
 
;; Special characters
;; These will never be in a symbol
(%define 'special (%%list #\( #\) #\Space))
 
;; Convert a digit character to a digit
(%define 'char-to-digit (%lambda char-to-digit (ch)
(%sub (%char-to-int ch) 48)))
 
;; Is the character something we want in our symbol?
(%define 'isalpha? (%lambda isalpha? (ch)
(%if (member ch special %char-eq?)
%nil
(%if (member ch digits %char-eq?)
%nil
%t))))
 
;; Convert a
(%define 'parse-integer* (%lambda parse-integer* (list num radix)
(%if list
 
 
(parse-integer* (%cdr list) (%add (%mul num radix) (char->digit (%car list))) radix)
num)))
(%define 'parse-integer (%lambda parse-integer (list)
(parse-integer* list 0 10)))
 
;; Is the character a whitespace
(%define 'whitespace? (%lambda whitespace? (ch)
(or3 (%char-eq? ch #\Space)
(%char-eq? ch #\Return)
(%char-eq? ch #\Newline))))
 
;; Length of a list
(%define 'length (%lambda length (list)
(%if list
(1+ (length (%cdr list)))
0)))
;; Convert a list to an array
(%define 'list->string* (%lambda list->string* (list str pos)
(%if list
(%progn
(%array-set str pos (%car list))
(list->string* (%cdr list) str (1+ pos)))
str)))
(%define 'list->string (%lambda list->string (list)
(let ((str (%make-array (length list) #\Space)))
(list->string* list str 0))))
 
;; Skip whitespace characters from an input stream
(%define 'skip-whitespace (%lambda skip-whitespace (s)
(let ((ch (s (%quote peek-char))))
(%if (%eq? ch 'eos)
ch
(%if (whitespace? ch)
(%progn
(s 'get-char)
(skip-whitespace s))
ch)))))
 
;; Tokenize a symbol
(%define 'tokenize-sym (%lambda tokenize-sym (s ch)
(%progn
(let ((type
(%if (member ch digits %char-eq?)
'integer
'symbol)))
(%define 'tknz
(%lambda tknz (s)
(let ((ch (s 'peek-char)))
(%if (%eq? ch 'eos)
%nil
(%if (whitespace? ch)
%nil
(%if (isalpha? ch)
(%progn
(%set! 'type 'symbol)
(%cons (s 'get-char)
(tknz s)))
(%if (member ch digits %char-eq?)
(%cons (s 'get-char)
(tknz s))
%nil)))))))
((%lambda snoc (a b)
(%cons b a))
(let ((lst (%cons ch (tknz s))))
((%if (%eq? type 'integer)
parse-integer
list->string)
lst))
type)))))
 
;; Tokenize a string
(%define 'tokenize-string-rec (%lambda tokenize-string-rec (s)
(let ((ch (s 'get-char)))
(%if (%char-eq? ch #\") ; XXX: Check for end of stream
%nil
 
(%cons ch (tokenize-string-rec s))))))
(%define 'tokenize-string (%lambda tokenize-string (s)
(let ((sl (tokenize-string-rec s)))
(%cons 'string (list->string sl)))))
 
;; Tokenize a hash object
(%define 'tokenize-hash-x (%lambda tokenize-hash-x (s)
(%progn
(%define 'rec (%lambda tokenize-hash-x-rec ()
(let ((ch (s 'peek-char)))
(%if (member ch digits-hex %char-eq?)
(%cons (s 'get-char) (rec))
%nil))))
(parse-integer* (rec) 0 16))))
(%define 'tokenize-hash (%lambda tokenize-hash (s)
(let ((ch (s 'get-char)))
(%if (%char-eq? ch #\\)
(%cons 'character (s 'get-char))
(%if (%char-eq? ch #\x)
(%cons 'integer (tokenize-hash-x s))
(%cons 'error "Unknown hash character"))))))
 
;; Tokenize a stream
(%define 'tokenize (%lambda tokenize (s)
(%progn
(skip-whitespace s)
(let ((ch (s 'get-char)))
(%if (%eq? ch 'eos)
(%cons 'eos %nil)
(%if (%char-eq? ch #\()
(%cons 'lparen %nil)
(%if (%char-eq? ch #\))
(%cons 'rparen %nil)
(%if (%char-eq? ch #\')
(%cons 'quote %nil)
(%if (%char-eq? ch #\")
(tokenize-string s)
(%if (%char-eq? ch #\#)
(tokenize-hash s)
(tokenize-sym s ch)))))))))))
 
;; Make a token stream
(%define 'make-token-stream (%lambda make-token-stream (s)
(let ((tok %nil))
(%lambda token-stream (cmd)
(%if (%eq? cmd 'next)
(%if tok
(let ((tok2 tok))
(%set! 'tok %nil)
tok2)
(tokenize s))
(%if (%eq? cmd 'peek)
(%if tok
tok
(%progn
(%set! 'tok (tokenize s))
tok))
%nil))))))
 
;; Parse a list from a token stream
(%define 'parse-list (%lambda parse-list (s)
(let ((tok (s 'peek)))
(let ((token (%car tok)))
(%if (%eq? token 'eos)
(%error "Parse error, missing rparen at end of stream")
(%if (%eq? token 'rparen)
(%progn
(s 'next)
%nil)
(%cons (parse s) (parse-list s))))))))
 
;; Check if the string is a T type
(%define 'is-t? (%lambda is-t? (str)
(%if (%num-eq? (%array-size str) 1)
(%if (%char-eq? (%array-get str 0) #\T)
%t
%nil)
%nil)))
 
;; Check if the string s a NIL type
(%define 'is-nil? (%lambda is-nil? (str)
(string=? str "NIL")))
 
;; Uppercase a string
(%define 'string-upper-rec (%lambda string-upper-rec (orig str i)
(%if (%num-eq? i (%array-size orig))
str
(%progn
(%array-set str i (char-upper (%array-get orig i)))
(string-upper-rec orig str (1+ i))))))
(%define 'string-upper (%lambda string-upper (str)
(let ((str2 (%make-array (%array-size str) #\a)))
(string-upper-rec str str2 0))))
;; Make a symbol of a string
;; T and NIL are "special" symbols
(%define 'symbolify (%lambda symbolify (sym)
(%if (%num-eq? (%array-size sym) 1)
(%if (is-t? sym)
%t
(%if (%char-eq? #\. (%array-get sym 0))
'%.
(intern sym)))
(%if (is-nil? sym)
%nil
(intern sym)))))
;; Parse a token stream
(%define 'parse (%lambda parse (s)
(let ((tok (s 'next)))
(%if (%eq? (%car tok) 'lparen)
(parse-list s)
(%if (or3 (%eq? (%car tok) 'integer) (%eq? (%car tok) 'string) (%eq? (%car tok) 'character))
(%cdr tok)
(%if (%eq? (%car tok) 'symbol)
(symbolify (string-upper (%cdr tok)))
(%if (%eq? (%car tok) 'quote)
(%cons '%quote (%cons (parse s) %nil)))))))))
 
;; Parse a string into cons cells
(%define 'read-from-string (%lambda read-from-string (str)
(let ((s (make-token-stream (make-string-stream str 0))))
(parse s))))
 
;; Write each character in the list to current output
(%define 'print-list* (%lambda print-list* (list)
(%if list
(%progn
(%put-char current-output (%car list))
(print-list* (%cdr list)))
%nil)))
 
;; Print a character
(%define 'print-char (%lambda print-char (ch)
(print-list* (%%list #\# #\\ ch))))
 
 
;; Check if an array is a string
(%define 'is-string?-rec (%lambda is-string?-rec (arr i)
(%if (%num-eq? i (%array-size arr))
%t
(%if (%num-eq? (%type (%array-get arr i)) +type-char+)
(is-string?-rec arr (1+ i))
%nil))))
(%define 'is-string? (%lambda is-string? (arr)
(is-string?-rec arr 0)))
 
;; Print a string
(%define 'print-string-rec (%lambda print-string-rec (arr i)
(%if (%num-eq? (%array-size arr) i)
%nil
(%progn
(%put-char current-output (%array-get arr i))
(print-string-rec arr (1+ i))))))
(%define 'print-string (%lambda print-string (arr)
(%progn
(%put-char current-output #\")
(print-string-rec arr 0)
(%put-char current-output #\"))))
 
;; Print an array
(%define 'print-array-rec (%lambda print-array-rec (arr i)
(%if (%num-eq? (%array-size arr) i)
%nil
(%progn
(print (%array-get arr i))
(%put-char current-output #\Space)
(print-array-rec arr (1+ i))))))
 
 
(%define 'print-array (%lambda print-array (arr)
; String is a special type of array
(%if (is-string? arr)
(print-string arr)
(%progn
(print-list* (%%list #\# #\[))
(%put-char current-output #\Space)
(print-array-rec arr 0)
(%put-char current-output #\])))))
 
;; See if a cons cell really is a list
(%define 'is-list? (%lambda is-list? (cons)
(%if (%num-eq? (%type cons) +type-cons+)
(is-list? (%cdr cons))
(%if (%num-eq? (%type cons) +type-nil+)
%t
%nil))))
;; Print a list
(%define 'print-list-rec (%lambda print-list-rec (list)
(%progn
(print (%car list))
(%if (%num-eq? (%type (%cdr list)) +type-nil+)
%nil
(%progn
(%put-char current-output #\Space)
(print-list-rec (%cdr list)))))))
(%define 'print-list (%lambda print-list (list)
(%progn
(%put-char current-output #\()
(print-list-rec list)
(%put-char current-output #\)))))
;; Print a cons cell
(%define 'print-cons (%lambda print-cons (cons)
(%if (is-list? cons)
(print-list cons)
(%progn
(%put-char current-output #\()
(print (%car cons))
(%put-char current-output #\Space)
(%put-char current-output #\.)
(%put-char current-output #\Space)
(print (%cdr cons))
(%put-char current-output #\))))))
 
;; Print an integer
(%define 'print-integer-rec (%lambda print-integer-rec (int list)
(%if (%num-eq? int 0)
list
(print-integer-rec (%if (%num-eq? *print-base* 10)
(%div int 10)
(%bitwise-shift int -4))
(%cons
(%if (%num-eq? *print-base* 10)
(%mod int 10)
(%bitwise-and int #xF))
list)))))
 
; XXX: Make it an array for direct lookup?
;; Integer to digit character mapping
(%define 'digit->char-map (%%list (%cons 0 #\0)
(%cons 1 #\1)
(%cons 2 #\2)
(%cons 3 #\3)
(%cons 4 #\4)
(%cons 5 #\5)
(%cons 6 #\6)
(%cons 7 #\7)
(%cons 8 #\8)
(%cons 9 #\9)
(%cons 10 #\A)
(%cons 11 #\B)
(%cons 12 #\C)
(%cons 13 #\D)
(%cons 14 #\E)
(%cons 15 #\F)
(%cons 10 #\a)
(%cons 11 #\b)
(%cons 12 #\c)
(%cons 13 #\d)
(%cons 14 #\e)
(%cons 15 #\f)))
;; Convert an integer (0 >= n < 10)
(%define 'digit->char-rec (%lambda digit->char-rec (int list)
(%if list
(%if (%num-eq? (%car (%car list)) int)
(%cdr (%car list))
(digit->char-rec int (%cdr list)))
#\?)))
(%define 'digit->char (%lambda digit->char (int)
(digit->char-rec int digit->char-map)))
 
;; Convert a character to a digit [0, F]
(%define 'char->digit-rec (%lambda digit->char-rec (ch list)
(%if list
(%if (%char-eq? (%cdr (%car list)) ch)
(%car (%car list))
(char->digit-rec ch (%cdr list)))
0)))
(%define 'char->digit (%lambda digit->char (ch)
(char->digit-rec ch digit->char-map)))
 
(%define 'print-integer (%lambda print-integer (int)
(%if (%num-eq? int 0)
(print-list* (%if (%num-eq? *print-base* 10)
(%%list #\0)
(%%list #\# #\x #\0)))
(print-list*
(let ((start-int (%if (%num-eq? *print-base* 10)
%nil
(%%list #\# #\x))))
(print-list* start-int)
(%if (%less-than? int 0)
(%cons #\- (map digit->char (print-integer-rec (%mul (%sub 0 1) int) %nil)))
(map digit->char (print-integer-rec int %nil))))))))
 
 
;; Print a function
(%define
'print-function
(%lambda
print-function (f)
(%progn
(%put-char current-output #\#)
(%put-char current-output #\()
(print (function-name f))
(%put-char current-output #\)))))
 
;; Print a builtin function
(%define
'print-builtin
(%lambda
print-builtin (b)
(%progn
(%put-char current-output #\#)
(%put-char current-output #\()
(print (%builtin-name b))
(%put-char current-output #\)))))
 
 
;; Print an object
(%define
'print
(%lambda
print (expr)
(%if (%num-eq? (%type expr) +type-t+)
(%put-char current-output #\T)
(%if (%num-eq? (%type expr) +type-nil+)
(print-list* (%%list #\N #\I #\L))
(%if (%num-eq? (%type expr) +type-char+)
(print-char expr)
(%if (%num-eq? (%type expr) +type-array+)
(print-array expr)
(%if (%num-eq? (%type expr) +type-cons+)
(print-cons expr)
(%if (%num-eq? (%type expr) +type-symbol+)
(print-string-rec (%symbol-to-string expr) 0)
(%if (%num-eq? (%type expr) +type-int+)
(print-integer expr)
(%if (%num-eq? (%type expr) +type-function+)
(print-function expr)
(%if (%num-eq? (%type expr) +type-builtin+)
(print-builtin expr)
(%put-char current-output #\#))))))))))))
 
;; Write newline
(%define 'newline (%lambda newline ()
(%progn
(%put-char current-output #\Newline)
(%put-char current-output #\Return)
nil)))
 
;; Parse the input from a device
(%define 'read-from-device (%lambda read-from-device (input-device)
(let ((s (make-token-stream (make-device-input-stream input-device))))
(parse s))))
 
;; Read line
(%define 'read-line
(%lambda read-line (input-device)
(let ((s (make-device-input-stream input-device)))
(%define 'rec (%lambda read-line-rec ()
(let ((ch (s 'get-char)))
(%if (or2 (%char-eq? #\Newline ch) (%char-eq? #\Return ch))
%nil
(%cons ch (rec))))))
(skip-whitespace s)
(list->string (rec)))))
 
;; Remove backspaced characters
(%define 'fix-backspace
(%lambda fix-backspace (strin)
(let ((str (%make-array (%array-size strin) #\Newline)))
(let ((size (%array-size strin)))
(%define 'rec
(%lambda fix-backspace-rec (i j)
(%if (%num-eq? j size)
(%if (%less-than? i j)
(%progn
(%array-set str i #\Newline)
(rec (1+ i) j))
str)
(%if (%char-eq? (%array-get strin j) #\Backspace)
(rec (%if (%num-eq? i 0) 0 (1- i)) (1+ j))
(%progn
(%array-set str i (%array-get strin j))
(rec (1+ i) (1+ j)))))))
(rec 0 0)))))
 
;; Macro system
;; Move to nth-lisp file, RSN
 
(%define 'macro-functions %nil)
;; defmacro
(%define 'defmacro-fn (%lambda %defmacro (name fn)
(%set! 'macro-functions
(%cons (%cons name fn)
macro-functions))))
 
(%define 'get-macro-fn (%lambda get-macro-fn (name)
(%progn
(%define 'rec
(%lambda get-macro-fn-rec (name list)
(%if list
(%if (%eq? (%car (%car list)) name)
(%cdr (%car list))
(rec name (%cdr list)))
%nil)))
(rec name macro-functions))))
;; Tree walker and expander
 
(%define 'fix-lambda-arguments
(%lambda fix-lambda-arguments (args)
(%progn
(%define 'rec (%lambda fix-lambda-arguments-rec (args)
(%if args
(%if (%eq? '%. (%car args))
(%car (%cdr args))
(%cons (%car args) (rec (%cdr args))))
%nil)))
(%if (%num-eq? (%type args) +type-cons+)
(rec args)
args))))
 
(%define 'fix-pair
(%lambda fix-pair (pair)
(%if (is-list? pair)
(%if (%num-eq? (length pair) 3)
(%if (%eq? '%. (%car (%cdr pair)))
(%%list (%car pair) (%car (%cdr (%cdr pair))))
pair)
pair)
pair)))
(%define 'expand-macro
(%lambda expand-macro (root)
(%if (%num-eq? (%type root) +type-cons+)
(let ((mfn (get-macro-fn (%car root))))
(%if mfn
(expand-macro (mfn root))
root))
root)))
(%define 'tree-walker
(%lambda tree-walker (root)
(%if (%num-eq? (%type root) +type-cons+)
(%if (%eq? (%car root) '%quote)
root
(let ((root (expand-macro (fix-pair root))))
(%if (%num-eq? (%type root) +type-cons+)
(%if (%eq? (%car root) '%lambda)
(%cons '%lambda
(%cons (%car (%cdr root))
(%cons (fix-lambda-arguments (%car (%cdr (%cdr root))))
(map tree-walker (%cdr (%cdr (%cdr root)))))))
(map tree-walker root))
root)))
root)))
 
;;; Move this to NTH-Lisp code base
;;; !!!
;; Lambda macro
(defmacro-fn 'lambda
(%lambda 'lambda-macro (root)
(list '%lambda
'anonymous
(%car (%cdr root))
(%cons '%progn
(%cdr (%cdr root))))))
 
(defmacro-fn 'named-lambda
(%lambda 'named-lambda-macro (root)
(list '%lambda
(%car (%cdr root))
(%car (%cdr (%cdr root)))
(%cons '%progn
(%cdr (%cdr (%cdr root)))))))
 
(defmacro-fn 'progn
(%lambda 'progn-macro (root)
(%cons '%progn
(%cdr root))))
(defmacro-fn 'quote
(%lambda 'quote-macro (root)
(%cons '%quote
(%cdr root))))
 
(defmacro-fn 'let
(%lambda 'let-macro (root)
(list (%cons 'named-lambda
(%cons 'let
(%cons (list (%car (%car (%car (%cdr root)))))
(%cdr (%cdr root)))))
(%car (%cdr (%car (%car (%cdr root))))))))
 
(defmacro-fn 'define
(%lambda 'define-macro (root)
(list '%define
(list '%quote (%car (%cdr root)))
(%car (%cdr (%cdr root))))))
(defmacro-fn 'setq!
(%lambda 'setq!-macro (root)
(list '%set!
(list '%quote (%car (%cdr root)))
(%car (%cdr (%cdr root))))))
 
(defmacro-fn 'cond
(%lambda 'cond-macro (root)
(%progn
(%define 'rec (%lambda 'cond-macro-rec (lst)
(%if lst
(let ((pair (%car lst)))
(list '%if
(%car pair)
(%car (%cdr pair))
(rec (%cdr lst))))
%nil)))
(rec (%cdr root)))))
 
(defmacro-fn 'if
(%lambda 'if-macro (root)
(list '%if
(%car (%cdr root))
(%car (%cdr (%cdr root)))
(%if (%num-eq? (length (%cdr root)) 2)
%nil
(%car (%cdr (%cdr (%cdr root))))))))
(defmacro-fn 'or
(%lambda 'or-macro (root)
(%progn
(%define 'rec (%lambda or-macro-rec (args)
(%if args
(list (list '%lambda 'anonymous (list 'x)
(list '%if
'x 'x
(rec (%cdr args))))
(%car args))
%nil)))
(rec (%cdr root)))))
(defmacro-fn 'and
(%lambda 'and-macro (root)
(%progn
(%define 'rec (%lambda and-macro-rec (args)
(%if args
(list '%if
(%car args)
(rec (%cdr args))
(%car args))
%t)))
(rec (%cdr root)))))
;; Reduce
(%define 'reduce (%lambda 'reduce (fn init list)
(%if list
(reduce fn (fn init (%car list)) (%cdr list))
init)))
 
;; Make a function that calls reduce with the first argument as the
;; init value and the rest of the arguments as the list.
;; reducer takes a function that will be used during the reduce as
;; the only input.
(%define 'reducer (%lambda 'reduce (fn identity)
(%lambda 'anonymous-reducer list
(%if list
(reduce fn (%if identity identity (%car list)) (%if identity list (%cdr list)))
identity))))
 
(%define '+ (reducer %add 0))
(%define '- (%lambda sub lst
(%if (%num-eq? (length lst) 1)
(%sub 0 (%car lst))
(reduce %sub (%car lst) (%cdr lst)))))
(%define '* (reducer %mul 1))
(%define '/ %div)
(%define 'mod %mod)
 
(%define '= %num-eq?)
(%define '< %less-than?)
(%define '> (%lambda 'greater-than? (a b)
(%if (or2 (%num-eq? a b)
(%less-than? a b))
%nil
%t)))
(%define 'car %car)
(%define 'cdr %cdr)
(%define 'cons %cons)
(%define 'set! %set!)
(%define 'set-car! %set-car!)
(%define 'set-cdr! %set-cdr!)
(%define 'make-array %make-array)
(%define 'array-get %array-get)
(%define 'array-size %array-size)
 
(defun append (li lu)
(%if li
(cons (car li) (append (cdr li) lu))
lu))
 
(defun null? (dings)
(%if (%eq? nil dings)
%t
%nil))
 
 
;;; !!! END
(%define
'combine
(%lambda
combine (f g) ; produces combination of single-argument
; functions f and g
(%lambda combination (x) (f (g x)))))
 
(%define 'caar (combine car car))
(%define 'cadr (combine car cdr))
(%define 'cdar (combine cdr car))
(%define 'cddr (combine cdr cdr))
(%define 'cdddr (combine cddr cdr))
(%define 'caddr (combine cadr cdr))
(%define 'cadddr (combine caddr cdr))
 
(%define 'igorev-state-func-frame car)
(%define 'igorev-state-condition cadr)
(%define 'igorev-state-iterations caddr)
 
(%define 'igorev-func-frame-func car)
(%define 'igorev-func-frame-env cadr)
(%define 'igorev-func-frame-eval-frame caddr)
(%define 'igorev-func-frame-parent cadddr)
 
(%define 'igorev-eval-frame-expr car)
(%define 'igorev-eval-frame-arg cadr)
(%define 'igorev-eval-frame-result caddr)
(%define 'igorev-eval-frame-phase cadddr)
(%define 'igorev-eval-frame-parent (combine caddr cddr))
 
(%define
'igorev-state-huge-success?
(%lambda
igorev-state-huge-success? (state)
(%eq? (igorev-state-condition state) nil)))
 
(%define
'igorev-state-result
(%lambda
igorev-state-result (state)
(igorev-eval-frame-result
(igorev-func-frame-eval-frame
(igorev-state-func-frame state)))))
 
(%define
'igorev-state-expr
(%lambda
igorev-state-expr (state)
(igorev-eval-frame-expr
(igorev-func-frame-eval-frame
(igorev-state-func-frame state)))))
 
(%define 'igorev-env-local-bindings car)
 
 
(%define
'function-name
(%lambda
function-name (f)
(%car (%function-data f))))
 
(%define
'function-param-list
(%lambda
function-param-list (f)
(%cadr (%function-data f))))
 
(%define
'function-expr
(%lambda
function-expr (f)
(%caddr (%function-data f))))
 
(%define
'function-env
(%lambda
function-end (f)
(%cadddr (%function-data f))))
 
 
 
(%define
'show-error-message
(%lambda
show-error-message (state)
(%progn
(display "Error: ")
(print (igorev-state-condition state))
(display " at ")
(print (igorev-state-expr state))
(newline)
(display " in ")
(print (igorev-func-frame-func (igorev-state-func-frame state)))
(newline))))
 
 
(%define
'display
(%lambda
display (str)
(%progn
(%define
'display-rec
(%lambda
display-rec (i)
(%if (%less-than? i (%array-size str))
(%progn
(%put-char current-output (%array-get str i))
(display-rec (1+ i)))
nil)))
(%if (is-string? str)
(display-rec 0)
(%error (list '%err-type-error str 'string))))))
(defun displine (str)
(display str)
(newline)
nil)
 
 
 
;; (%define
;; 'new-environment
;; (%lambda
;; new-environment (parent)
;; (%cons %nil parent)))
 
(defun new-environment (parent)
(%cons %nil parent))
 
(defun debug (state)
(displine "Entering debugger")
(let ((top-fframe (igorev-state-func-frame state)))
(let ((top-eframe (igorev-func-frame-eval-frame top-fframe)))
(dbg-show-fframe top-fframe)
(dbg-show-eframe top-eframe)
(dbg-repl state top-fframe '() top-eframe '()))))
(defun dbg-show-fframe (f)
(displine "Current function frame:")
(display " Function: ")
(print (igorev-func-frame-func f))
(newline)
(display " Local bindings: ")
(print (igorev-env-local-bindings
(igorev-func-frame-env f)))
(newline))
 
(defun dbg-show-eframe (e)
(displine "Current eval frame:")
(display " Expr: ")
(print (igorev-eval-frame-expr e))
(newline)
(display " Arg: ")
(print (igorev-eval-frame-arg e))
(newline)
(display " Result: ")
(print (igorev-eval-frame-result e))
(newline)
(display " Phase: ")
(print (igorev-eval-frame-phase e))
(newline))
 
(defun dbg-show-fstack (frame descendants)
(defun print-frame (f num is-current)
(%if is-current (display "(*)") nil)
(print num)
(display ": ")
(print (igorev-func-frame-func f))
(newline))
(defun print-frames (frames i)
(%if frames
(%progn
(print-frame (car frames) i
(%eq? (car frames) frame))
(print-frames (cdr frames) (1+ i)))
nil))
(defun collect-frames (frame rest)
(%if frame
(collect-frames (igorev-func-frame-parent frame)
(cons frame rest))
rest))
(print-frames (collect-frames frame descendants) 0))
 
(defun dbg-show-estack (frame descendants)
(defun print-frame (f num is-current)
(%if is-current (display "(*)") nil)
(print num)
(display ": ")
(print (igorev-eval-frame-expr f))
(newline))
(defun print-frames (frames i)
(%if frames
(%progn
(print-frame (car frames) i
(%eq? (car frames) frame))
(print-frames (cdr frames) (1+ i)))
nil))
(defun collect-frames (frame rest)
(%if frame
(collect-frames (igorev-eval-frame-parent frame)
(cons frame rest))
rest))
(print-frames (collect-frames frame descendants) 0))
 
(defun dbg-show-env (fframe)
(displine "(TODO)"))
 
(defun dbg-repl (state fframe fframes-below eframe eframes-below)
(%define 'continue %t)
(defun env ()
(igorev-func-frame-env fframe))
(defun deval (expr)
(%eval expr (env)))
(defun up ()
(let ((parent (igorev-func-frame-parent fframe)))
(%if parent
(%progn
(%set! 'fframes-below (cons fframe fframes-below))
(%set! 'fframe parent)
(%set! 'eframe (igorev-func-frame-eval-frame fframe))
(%set! 'eframes-below '())
(displine "Moved one function frame up"))
(displine "Current function frame is an orphan"))))
(defun down ()
(%if fframes-below
(%progn
(%set! 'fframe (car fframes-below))
(%set! 'fframes-below (cdr fframes-below))
(%set! 'eframe (igorev-func-frame-eval-frame fframe))
(%set! 'eframes-below '())
(displine "Moved one function frame down"))
(displine "Current function frame is childless")))
(defun eup ()
(let ((parent (igorev-eval-frame-parent eframe)))
(%if parent
(%progn
(%set! 'eframes-below (cons eframe eframes-below))
(%set! 'eframe parent)
(displine "Moved one eval frame up"))
(displine "Current eval frame is an orphan"))))
(defun edown ()
(%if eframes-below
(%progn
(%set! 'eframe (car eframes-below))
(%set! 'eframes-below (cdr eframes-below))
(displine "Moved one eval frame down"))
(displine "Current eval frame is childless")))
(defun show (what)
(%if (%eq? what 'fframe)
(dbg-show-fframe fframe)
(%if (%eq? what 'eframe)
(dbg-show-eframe eframe)
(%if (%eq? what 'env)
(dbg-show-env fframe)
(%if (%eq? what 'fstack)
(dbg-show-fstack fframe fframes-below)
(%if (%eq? what 'estack)
(dbg-show-estack eframe eframes-below)
(displine "What what?")))))))
(defun quit ()
(%set! 'continue %nil))
(defun read ()
(display "dbg> ")
(let ((expr (tree-walker
(read-from-string (fix-backspace (read-line current-input))))))
(newline)
expr))
(defun eval/print (expr)
(let ((state (%eval-partial
(%make-eval-state expr
(new-environment (%current-environment)))
0)))
(%if (igorev-state-huge-success? state)
(%progn
(display "Result: ")
(print (igorev-state-result state))
(newline))
(show-error-message state))))
 
(eval/print (read))
(%if continue
(dbg-repl state fframe fframes-below eframe eframes-below)
(displine "Exiting debugger")))
 
 
(defun try (expr)
(let ((state (%eval-partial
(%make-eval-state (tree-walker expr)
(%current-environment))
0)))
(%if (igorev-state-huge-success? state)
(list 'success (igorev-state-result state))
(list 'interrupt (cdr (igorev-state-condition state)) state))))
 
(defun catch-fn (handlers expr)
(defun find-handler (condition handlers)
(%if handlers
(%if ((caar handlers) condition)
(cdar handlers)
(find-handler condition (cdr handlers)))
nil))
(let ((result (try expr)))
(%if (%eq? (car result) 'success)
(cadr result)
(let ((condition (cadr result)))
(let ((handler (find-handler condition handlers)))
(%if handler
(handler condition)
(%error condition)))))))
 
(defmacro-fn
'catch
(%lambda
catch-macro (root)
(let ((cond-var (cadr root)))
(let ((handlers (caddr root)))
(let ((body (cdddr root)))
(list 'catch-fn
(cons
'list
(map (%lambda
catch-macro-create-handler-function (handler)
(list 'cons
(list '%lambda 'catch-handler-predicate (list cond-var)
(car handler))
(list '%lambda 'catch-handler-function (list cond-var)
(cadr handler))))
handlers))
(list '%quote (cons '%progn body))))))))
(defun condition-type (condition)
(%if (is-list? condition)
(car condition)
condition))
 
 
 
(%define '*igorrepl-continue* %t)
(%define
'quit
(%lambda
quit () ; make it all go away
(%set! '*igorrepl-continue* nil)))
 
;; REPL
(%define 'igorrepl (%lambda igorrepl (n env)
(%progn
(display "IGORrepl: ")
(let ((state (%make-eval-state
(tree-walker
(read-from-string (fix-backspace (read-line current-input))))
env)))
(newline)
(let ((state (%eval-partial state 0)))
(let ((cond (%car (%cdr state))))
(newline)
(%if (igorev-state-huge-success? state)
(%progn
(display "Result: ")
(print (igorev-state-result state)))
(%progn
(show-error-message state)
(debug state)))
(newline)
(%if *igorrepl-continue*
(%if (%num-eq? n 1)
%t
(igorrepl (%if (%num-eq? n 0) 0 (1- n)) env))
nil)))))))
 
 
;;(intern-symbols %symbol-table)
 
(display "boot program $Rev: 1441 $")
(newline)
(%define
'looptyloop
(%lambda
looptyloop ()
(let ((state (%make-eval-state '(igorrepl 0 (new-environment (%current-environment)))
(%current-environment))))
(let ((new-state (%eval-partial state 0)))
(%if (igorev-state-huge-success? new-state)
(%progn
(display "Happy Happy Joy Joy")
(newline))
(%progn
(newline)
(display "ERROR IN TOP-LEVEL REPL")
(newline)
(show-error-message new-state)
(looptyloop)))))))
(looptyloop)
))
 
/microprogram_assembler/package.lisp
0,0 → 1,13
;;;
;;; Package definition
;;;
 
(defpackage #:mcasm
(:use :cl))
 
(in-package #:mcasm)
 
;; The pre-assembled data object
(defvar *pre-assembly-data* ())
 
 
/microprogram_assembler/assembler.lisp
0,0 → 1,837
;;;
;;; Assembler!
;;;
 
(in-package #:mcasm)
 
(defvar *assembler-constants* (make-hash-table :test 'equal))
(defvar *assembler-labelnumbers* 0)
 
(defun next-labelnumber ()
(incf *assembler-labelnumbers*))
 
(defstruct constant-info
type
name
number)
 
(defun constant-info-to-string (info &key (key nil))
(format nil "~A~A~A~A"
(constant-info-type info)
(if key
"-"
" ")
(constant-info-name info)
(if key ""
(format nil " ~X" (constant-info-number info)))))
 
(defmacro def-const ((name number &key (type "const")) &body body)
`(let ((info (make-constant-info :type ,type
:name ',name
:number ,number)))
(setf (gethash (constant-info-to-string info :key nil) *assembler-constants*) info)
,@body))
 
(defmacro def-branch (name number)
`(def-const (,name ,number :type "branch")
(defparameter ,(intern (format nil "-BRANCH-~A-" name)) ,number)))
 
(def-branch O 1)
(def-branch C 2)
(def-branch N 4)
(def-branch Z 8)
(def-branch B 16)
 
(defmacro def-type (name number)
`(def-const (,name ,number :type "type")
(defparameter ,(intern (format nil "+TYPE-~A+" name)) ,number)))
 
(def-type none #x0)
(def-type int #x1)
(def-type float #x3)
(def-type cons #x4)
(def-type snoc #x5)
(def-type ptr #x6)
(def-type array #x7)
(def-type nil #x8)
(def-type t #x9)
(def-type char #xA)
(def-type symbol #xB)
(def-type function #xC)
(def-type builtin #xD)
 
(defparameter +n-regs+ #x400) ; number of registers
 
(defmacro defreg (name number)
`(def-const (,name ,number :type "reg")
(defparameter ,(intern (format nil "$~A" name)) ,number)))
 
(defmacro defmem (name number)
`(def-const (,name ,number :type "memory")
(defparameter ,(intern (format nil "%~A" name)) ,number)))
 
(defreg zero #x00)
(defreg one #x01)
(defreg two #x02)
 
(defreg s-addr #x03) ; address where an sframe has been stored
;;(defreg s-name #x04) ;; TODO do we want this?
;;(defreg s-fstack #x04)
(defreg s-condition #x04)
(defreg s-iterations #x05)
(defreg s-parent #x06)
 
;;(defreg e/f-addr #x07)
;;(defreg e/f-parent-addr #x08)
 
(defreg s-tmp #x09)
(defreg e-tmp1 #x0A)
(defreg e-tmp2 #x0B)
(defreg e-tmp3 #x0C)
(defreg f-tmp1 #x0D)
(defreg f-tmp2 #x0E)
(defreg f-tmp3 #x0F)
 
;;(defreg e-addr #x09) ;; TODO remove this
(defreg e-expr #x10)
(defreg e-arg #x11)
(defreg e-result #x12)
(defreg e-phase #x13)
(defreg e-addr #x14)
 
;;(defreg f-addr #x15) ;; TODO remove this
(defreg f-func #x16)
(defreg f-env #x17)
;;(defreg f-estack #x18)
(defreg f-addr #x19)
 
(defreg alloc-addr #x20)
(defreg alloc-top #x21)
(defreg alloc-size #x22)
 
(defreg store-list-start #x23)
(defreg store-list-end #x24)
(defreg store-list-addr #x25)
(defreg store-list-reg #x26)
(defreg store-list-val #x27)
 
(defreg apply-result #x28)
(defreg apply-result-val #x29)
(defreg apply-func #x2A)
(defreg builtin-arg1 #x2B)
(defreg builtin-arg2 #x2C)
(defreg builtin-arg3 #x2D)
(defreg builtin-arg1-val #x2E)
(defreg builtin-arg2-val #x2F)
(defreg builtin-arg3-val #x30)
 
(defreg tmp-result #x33)
 
(defreg apply-argc #x34)
(defreg apply-required-argc #x35)
 
(defreg car #x40)
(defreg cdr #x41)
(defreg list-terminator #x42)
 
(defreg interrupt-tmp #x45)
 
(defreg params-car #x50)
(defreg args-car #x51)
(defreg apply-eval-expr #x52)
(defreg apply-eval-env #x53)
(defreg apply-apply-args #x54)
(defreg apply-apply-params #x55)
(defreg env #x56)
 
(defreg tmp1 #x57)
(defreg tmp2 #x58)
(defreg tmp3 #x59)
(defreg tmp4 #x5A)
 
(defreg fetch-args-arg-reg #x60)
(defreg fetch-args-arg #x61)
(defreg fetch-args-argval-reg #x62)
(defreg fetch-args-argval #x63)
(defreg fetch-args-arglist #x64)
 
(defreg io-devnr #x65)
(defreg io-new-devnr #x66)
(defreg io-mem-addr #x67)
 
(defreg message #x68)
(defreg message-shift #x69)
(defreg message-mask #x6A)
(defreg message-tmp1 #x6B)
(defreg message-tmp2 #x6C)
 
(defreg mc-stack-top #x090)
(defreg mc-stack-min #x091)
(defreg mc-stack-max #x09E)
 
(defreg e/f-top #x09F)
(defreg e/f-below-marker #x100)
(defreg e/f-min #x104)
(defreg e/f-min-expr #x104)
(defreg e/f-min-arg #x105)
(defreg e/f-min-result #x106)
(defreg e/f-min-phase #x107)
 
;; (defreg e/f-max-expr #x118)
;; (defreg e/f-max-arg #x119)
;; (defreg e/f-max-result #x11A)
;; (defreg e/f-max-phase #x11B)
;; (defreg e/f-max #x11B)
;; (defreg e/f-above-marker #x11C)
 
(defreg e/f-max-expr #x3F8)
(defreg e/f-max-arg #x3F9)
(defreg e/f-max-result #x3FA)
(defreg e/f-max-phase #x3FB)
(defreg e/f-max #x3FB)
(defreg e/f-above-marker #x3FC)
(defreg e/f-frame-size #x3FD)
 
(defreg init1 #x3F0)
(defreg init2 #x3F1)
(defreg init3 #x3F2)
(defreg init-counter #x3F3)
(defreg init-counter2 #x3F4)
(defreg init-shift1 #x3F5)
(defreg init-shift2 #x3F6)
(defreg init-char-mask #x3F7)
(defreg init-chars-start #x3F8)
(defreg init-symbol-addr #x3F9)
(defreg init-symbol-str-addr #x3FA)
(defreg init-symbol-char-addr #x3FB)
(defreg init-symbol-array #x3FC)
 
;; needed variables (registers) for gc
 
;; register values that must be predefined
;; set these when testing gc standalone in emulator
(defreg gc-maxblocks #x70) ;; total memory size
(defreg gc-spaces #x71) ;; number of spaces we'll divide the memory in
(defreg gc-startofmem #x76) ;; start of variable address space
 
;; registers set by evaluator before invoking gc
;; set these when testing gc standalone in emulator
(defreg gc-rootptr #x78) ;; pointer to topmost object! hopefully
;; there will be only one
 
;; registers set by init, keep these throughout
(defreg gc-spacesize #x72) ;; size of each space: maxblocks / spaces
(defreg gc-sup #x73) ;; first address beyond legal space:
;; spaces * spacesize (NB: can be lower than
;; maxblocks)
(defreg gc-gcspace #x74) ;; start of gc exclusize space, sup - spacesize
 
;; registers used by everyone
(defreg gc-firstfree #x75) ;; first free memory block
;; (might exist already in other microcode)
 
;; scratch registers, can be used when gc is not running (but gc will
;; destroy them)
 
(defreg gc-1 #x80) ;; temp
(defreg gc-vi #x83)
(defreg gc-t #x84) ;; ptr-rev
(defreg gc-x #x85) ;; ptr-rev
(defreg gc-y #x86) ;; ptr-rev
(defreg gc-v #x87) ;; ptr-rev
(defreg gc-followp #x88) ;; ptr-rev
(defreg gc-cannext #x89) ;; ptr-rev
(defreg gc-canprev #x8a) ;; ptr-rev
 
(defreg gc-temp #x8b)
(defreg gc-mem #x8c)
(defreg gc-from #x84) ;; at this stage we're no longer using
(defreg gc-to #x85) ;; some of the above variables
(defreg gc-val #x86)
(defreg gc-temp2 #x87)
(defreg gc-baseaddr #x88)
 
(defreg gc-mem-limit #x7F)
 
;; div-variables (reusing gc-registers)
(defreg div-low #x88)
(defreg div-high #x89)
(defreg div-mid #x8a)
(defreg div-res #x8b)
(defreg div-sign #x8c)
(defreg mod-val1 #x87)
(defreg mod-val2 #x86)
 
(defparameter +gc-free+ #x00)
(defparameter +gc-used+ #x01)
 
(defparameter +gc-spaces+ #xA)
 
(defparameter +gc-limit+ #x1000) ; if free space is less than this, GC should be run
 
 
;; memory:
 
(defmem nil #x00)
(defmem t #x01)
(defmem if #x02)
(defmem quote #x03)
(defmem lambda #x04)
(defmem progn #x05)
 
(defparameter +first-builtin+ #x06)
(defmem cons #x06)
(defmem car #x07)
(defmem cdr #x08)
(defmem eval #x09)
(defmem apply #x0A)
(defmem type #x0B)
(defmem make-array #x0C)
(defmem array-size #x0D)
(defmem array-get #x0E)
(defmem array-set #x0F)
(defmem make-symbol #x10)
(defmem symbol-to-string #x11)
(defmem char-to-int #x12)
(defmem int-to-char #x13)
(defmem get-char #x14)
(defmem put-char #x15)
(defmem num-devices #x16)
(defmem device-type #x17)
(defmem set-address #x18)
(defmem get-address #x19)
(defmem error #x1A)
(defmem add #x1B)
(defmem sub #x1C)
(defmem mul #x1D)
(defmem div #x1E)
(defmem bitwise-and #x1F)
(defmem bitwise-or #x20)
(defmem bitwise-not #x21)
(defmem bitwise-shift #x22)
(defmem current-environment #x23)
(defmem make-eval-state #x24)
(defmem eval-partial #x25)
(defmem define #x26)
(defmem undefine #x27)
(defmem eq? #x28)
(defmem num-eq? #x29)
(defmem char-eq? #x2A)
(defmem less-than? #x2B)
(defmem mod #x2C)
(defmem set! #x2D)
(defmem set-car! #x2E)
(defmem set-cdr! #x2F)
(defmem function-data #x30)
(defmem builtin-name #x31)
(defmem device-size #x32)
(defmem device-status #x33)
(defparameter +last-builtin+ %device-status)
(defparameter +first-magic-var+ +first-builtin+)
(defparameter +last-magic-var+ +last-builtin+)
 
(defmem symbol-table #x3F)
(defparameter +first-phase+ #x40)
(defmem phase-eval #x40)
(defmem phase-eval-args #x41)
(defmem phase-apply #x42)
(defmem phase-eval-if #x43)
(defmem phase-initial #x44)
(defmem phase-env-lookup #x45)
(defmem phase-env-lookup-local #x46)
(defmem phase-apply-function #x47)
(defmem phase-bind-args #x48)
(defmem phase-eval-progn #x49)
(defmem phase-eval-args-top #x4A)
(defmem phase-eval-args-cdr #x4B)
(defmem phase-eval-args-cons #x4C)
(defmem phase-eval-symbol #x4D)
(defmem phase-set! #x4E)
(defparameter +last-phase+ %phase-set!)
 
(defmem timeout #x50)
(defmem err-invalid-phase #x51)
(defmem err-unbound-symbol #x52)
(defmem err-invalid-param-list #x53)
(defmem err-too-few-args #x54)
(defmem err-too-many-args #x55)
(defmem err-invalid-state #x56)
(defmem err-invalid-arg-list #x57)
(defmem err-type-error #x58)
(defmem err-not-a-list #x59)
(defmem err-not-a-function #x5A)
(defmem err-invalid-function #x5B)
(defmem err-malformed-form #x5C)
(defmem err-invalid-builtin #x5D)
(defmem err-invalid-array-index #x5E)
(defmem err-invalid-env #x5F)
(defmem err-not-a-pair #x60)
(defmem err-io-error #x61)
(defmem err-division-by-zero #x62)
(defmem err-overflow #x63)
(defparameter +last-symbol+ %err-overflow)
 
(defmem area-builtins #x100)
(defmem area-chars #x200)
(defmem area-ints #x280)
(defmem area-strings #x300)
(defmem area-symlist #xE00)
 
(defparameter +constant-chars+ (- %area-ints %area-chars))
(defparameter +constant-ints+ (- %area-strings %area-ints))
 
(defmem memory-root #xFFE)
(defmem mem-reserved-top #x1000)
(defmem boot-prog-start %mem-reserved-top)
 
(defparameter +memory-size+ (* 2 (* 1024 1024)))
 
(defmem io-mem-addr #x3FFFF00) ; TODO too large for immediate value
(defmem io-devices #x00)
(defmem io-curdev #x01)
(defmem io-cli #x02)
(defmem io-sai #x03)
(defmem io-intrdev #x04)
(defmem io-object #x10)
(defmem io-addr-l #x11)
(defmem io-addr-h #x12)
(defmem io-size-l #x13)
(defmem io-size-h #x14)
(defmem io-status #x15)
(defmem io-identification #x16)
(defmem io-irqenable #x17)
 
(defparameter +dev-boot+ #x03)
(defparameter +dev-serial+ #x00)
 
 
;;; Helper functions
 
;; Convert a argument to the argument type
(defun argument-to-type (arg)
(typecase arg
(integer 'imm)
(keyword 'label)
(t 'other)))
 
;; Make the instruction
;; Only set the opcode
(defun make-inst-opcode (opcode &key (debug 0) (break 0))
(let ((inst 0))
(setf (ldb (byte 6 42) inst) opcode)
(setf (ldb (byte 1 41) inst) debug)
(setf (ldb (byte 1 40) inst) break)
inst))
 
;; Parse an integer symbol and return the register number
(defun reg-to-num (reg)
(typecase reg
(symbol
(parse-integer (subseq (format nil "~A" reg) 1)))
(integer
reg)))
 
(defmacro rewrite-inst-part (inst &key from size value)
`(setf (ldb (byte ,size ,from) ,inst) ,value))
;; Make a function that returnes the binary representation of an instruction
(defmacro set-instruction ((&rest rest) &body body)
(let ((opcodevar (gensym))
(debugvar (gensym))
(instvar (gensym))
(breakvar (gensym)))
`(lambda (,opcodevar ,@rest &key (,debugvar 0) (,breakvar 0))
(let ((,instvar (make-inst-opcode ,opcodevar :debug ,debugvar :break ,breakvar)))
,@(loop for part in body
collect (cons 'rewrite-inst-part (cons instvar part)))
,instvar))))
 
;; The different opcode formats
(defparameter +opcodeformats+
`(
(noarg . (() ,(set-instruction ())))
(mem . ((r r imm) ,(set-instruction (r1 r2 imm)
(:size 11 :from 29 :value (reg-to-num r1))
(:size 11 :from 18 :value (reg-to-num r2))
(:size 18 :from 0 :value imm))))
(data . ((r r) ,(set-instruction (r1 r2)
(:size 11 :from 29 :value (reg-to-num r1))
(:size 11 :from 18 :value (reg-to-num r2)))))
(dataimm . ((r imm) ,(set-instruction (r1 imm)
(:size 11 :from 29 :value (reg-to-num r1))
;(:size 11 :from 18 :value (reg-to-num r2))
(:size 29 :from 0 :value imm))))
(onereg . ((r) ,(set-instruction (r1)
(:size 11 :from 29 :value (reg-to-num r1)))))
(alu . ((r r) ,(set-instruction (r1 r2)
(:size 11 :from 29 :value (reg-to-num r1))
(:size 11 :from 18 :value (reg-to-num r2)))))
(argtype0 . ((imm) ,(set-instruction (imm)
(:size 40 :from 0 :value imm))))
(argtype1 . ((r imm) ,(set-instruction (r1 imm)
(:size 11 :from 29 :value (reg-to-num r1))
(:size 29 :from 0 :value imm))))
(branch . ((r imm imm imm) ,(set-instruction (r1 mask flag addr)
(:size 11 :from 29 :value (reg-to-num r1))
(:size 8 :from 21 :value mask)
(:size 8 :from 13 :value flag)
(:size 13 :from 0 :value addr))))
))
 
;; Get the function from a format type
(defun get-format-function (format)
(second (cdr (assoc format +opcodeformats+))))
 
;; Add an instruction to the list
(defun add-instruction (opcode args function)
(setf *pre-assembly-data*
(append
(list (list opcode args function))
*pre-assembly-data*)))
 
;; Define an instruction
;; The generated function returns a list that contains the opcode,
;; the arguments and the function that makes the bit representation.
(defmacro make-instruction (name format opcode)
`(defun ,(intern (format nil "%~A" name)) (&rest args)
(when (eq *assembler-state* :gather)
(incf *assembler-position*))
(let ((f (cdr (assoc ',format +opcodeformats+))))
(when (not f)
(error "Missing opcode group for ~A for instruction ~A" ',format ',name))
(add-instruction ,opcode args f))))
 
;; Write a 48bit binary value to a stream
(defun write-48bit-unsigned (value s)
(write-byte (ldb (byte 8 40) value) s)
(write-byte (ldb (byte 8 32) value) s)
(write-byte (ldb (byte 8 24) value) s)
(write-byte (ldb (byte 8 16) value) s)
(write-byte (ldb (byte 8 8) value) s)
(write-byte (ldb (byte 8 0) value) s))
 
;; Assemble our instructions
(defun assemble-it (pre-assembly stream &key output-format simulator-lines)
(let ((pre-assembly (copy-tree (reverse pre-assembly))))
;; Assemble and write out
(format t "Writing out assembly~%")
(let ((instructions (loop for a in pre-assembly
unless (labelp a)
collect (apply (second (third a)) (first a) (second a)))))
(let ((number-of-instructions (length instructions)))
(dolist (inst instructions)
(cond ((eq output-format :human-readable)
(format stream "~12,'0X -- ~48,'0B~%" inst inst))
((eq output-format :simulator)
(format stream "~48,'0B~%" inst))
(t
(write-48bit-unsigned inst stream))))
(when simulator-lines
(dotimes (i (- simulator-lines number-of-instructions))
(format stream "~48,'0B~%" 0)))))))
 
;; Empty assembler cache
(defun reset-assembler ()
(setf *pre-assembly-data* (list)))
 
;;; Setup instructions and reset the assembler
(defun setup-assembler ()
(make-instruction nop noarg #x00)
(make-instruction halt noarg #x01)
 
;; ALU
(make-instruction add alu #x02)
(make-instruction sub alu #x03)
(make-instruction mul alu #x04)
(make-instruction div alu #x05)
(make-instruction and alu #x06)
(make-instruction or alu #x07)
(make-instruction xor alu #x08)
(make-instruction not alu #x09)
(make-instruction shift-l alu #x0A)
(make-instruction mod alu #x0B)
(make-instruction shift-r alu #x0C)
 
;; Memory
(make-instruction load mem #x10)
(make-instruction store mem #x11)
 
;; Branch
(make-instruction branch branch #x16)
 
;; Status
(make-instruction set-flag argtype1 #x17)
(make-instruction clear-flag argtype0 #x18)
(make-instruction get-flag argtype1 #x19)
 
;; Data
(make-instruction get-type data #x20)
(make-instruction set-type data #x21)
(make-instruction set-type-imm dataimm #x22)
(make-instruction set-datum data #x23)
(make-instruction set-datum-imm dataimm #x24)
(make-instruction get-gc data #x25)
(make-instruction set-gc data #x26)
(make-instruction set-gc-imm dataimm #x27)
 
(make-instruction cpy data #x28)
 
;; Compare
(make-instruction cmp-type data #x29)
(make-instruction cmp-type-imm dataimm #x2A)
(make-instruction cmp-datum data #x2B)
(make-instruction cmp-datum-imm dataimm #x2C)
(make-instruction cmp-gc data #x2D)
(make-instruction cmp-gc-imm dataimm #x2E)
(make-instruction cmp data #x2F)
 
;; Leds
(make-instruction set-leds onereg #x3F)
(reset-assembler)
t)
 
;; Info gathering or assembling state
;; The first get labels information and so on, the second assemble correct instructions
(defvar *assembler-state*)
(defvar *assembler-labels*)
(defvar *assembler-position*)
 
;; Debug functions
 
;; Write labels
(defun write-labels (file labels)
(format t "Writing out label information~%")
(with-open-file (s
(concatenate 'string file ".labels")
:element-type 'character
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(maphash
(lambda (key value)
(format s "~A ~X~%" key value))
labels)))
 
;; Write constant information
(defun write-constants (file constants labels)
(format t "Writing constant information~%")
(with-open-file (s
(concatenate 'string file ".const")
:element-type 'character
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(maphash
(lambda (key value)
(format s "label ~A ~X~%" key value))
labels)
(maphash (lambda (key value)
(declare (ignore key))
(format s "~A~%" (constant-info-to-string value)))
constants)))
 
;; The main assembly macro
;; Adds inst-prefixes and fixes labels
(defmacro with-assembly ((outfile &key output-format simulator-lines) &body body)
(let ((streamvar (gensym "STREAM")))
`(let ((*assembler-labels* (make-hash-table))
(*assembler-state* :gather)
(*assembler-position* 0))
(setf *assembler-labelnumbers* 0)
,@(loop
for inst in (copy-tree body)
when (not (labelp inst))
collect (rewrite-instruction inst :gather)
when (labelp inst)
collect `(setf (gethash ,inst *assembler-labels*) *assembler-position*))
(setf *assembler-labelnumbers* 0)
(format t "We got ~D instructions~%" *assembler-position*)
(with-open-file (,streamvar ,outfile
:element-type ,(cond ((or (eq output-format :human-readable)
(eq output-format :simulator))
''character)
(t ''unsigned-byte))
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(setf *assembler-state* :assemble)
(reset-assembler)
,@(loop
for inst in body
when (not (labelp inst))
collect (rewrite-instruction inst :assemble))
;; Write out assembled exectuable
(assemble-it *pre-assembly-data* ,streamvar :output-format ,output-format :simulator-lines ,simulator-lines)
;; Output debug info
(write-constants ,outfile *assembler-constants* *assembler-labels*)
(write-labels ,outfile *assembler-labels*)))))
;;; Microcode instructions
 
(defmacro with-new-label ((prefix var) &body body)
`(let ((,var (intern (format nil "~A-~A" (string-upcase ,prefix) (next-labelnumber)) (find-package "KEYWORD"))))
,@body))
 
(defmacro force-label (label)
`(when (labelp ,label)
(if (eq *assembler-state* :gather)
(setf ,label 0)
(progn
(unless (gethash ,label *assembler-labels*)
(error "Unknown label: ~A" ,label))
(setf ,label (gethash ,label *assembler-labels*))))))
 
(defmacro with-force-label ((label) &body body)
(if (integerp label)
`(progn
,@body)
`(let ((,label ,label))
(force-label ,label)
,@body)))
 
(defmacro with-force-label* ((var label) &body body)
`(let ((,var ,label))
(force-label ,var)
,@body))
 
(defmacro %when (comparison &body body)
`(with-new-label ("when" end)
,comparison
(branchimm-false end)
,@body
(make-label end)))
 
(defmacro %when-not (comparison &body body)
`(with-new-label ("when" end)
,comparison
(branchimm end)
,@body
(make-label end)))
 
(defmacro when= ((r1 r2) &body body)
`(with-new-label ("when=" end)
(%cmp-datum ,r1 ,r2)
(branchimm-false end)
,@body
(make-label end)))
 
(defmacro when!= ((r1 r2) &body body)
`(with-new-label ("when=" end)
(%cmp-datum ,r1 ,r2)
(branchimm end)
,@body
(make-label end)))
 
(defun some-stuff ()
(make-integer 3 4)
(make-integer 4 4)
(when= (3 4)
(make-integer 5 4)))
 
;; Make a indirect register
(defun indirect-register (reg)
(let ((i reg))
(setf (ldb (byte 1 10) i) 1)
i))
 
;; Branch
 
(defmacro %branch* (reg offset &rest flags)
(let ((maskvar (gensym))
(flagvar (gensym)))
`(let ((,maskvar (funcall #'logior ,@(loop for flag in flags
collect (intern (format nil "-BRANCH-~A-" (if (listp flag) (cadr flag) flag))))))
(,flagvar (funcall #'logior ,@(loop for flag in flags
when (not (listp flag))
collect (intern (format nil "-BRANCH-~A-" flag))))))
(%branch ,reg ,maskvar ,flagvar ,offset))))
 
(defun branchimm* (mask flag addr)
(with-force-label (addr) ;; Hack to fix labels in a few places, sorry about this.
(%branch $zero mask flag addr)))
 
;; Immediate branch true
(defun branchimm (addr)
(branchimm* #x8 #x8 addr))
 
;; Immediate branch false
(defun branchimm-false (addr)
(branchimm* #x8 0 addr))
 
;; Jmp
(defun jump (r addr)
(with-force-label (addr)
(%branch r 0 0 addr)))
 
(defun jump-imm (addr)
(with-force-label (addr)
(jump $zero addr)))
 
(defun jump-reg (r)
(jump r 0))
 
(defun make-object-imm (reg type value)
(%set-type-imm reg type)
(%set-datum-imm reg value))
 
(defun make-integer (reg value)
(make-object-imm reg +type-int+ value))
 
(defun %add* (d a b)
(%cpy d a)
(%add d b))
 
(defun %sub* (d a b)
(%cpy d a)
(%sub d b))
 
(defun %mul* (d a b)
(%cpy d a)
(%mul d b))
 
(defun %div* (d a b)
(%cpy d a)
(%div d b))
 
(defun %mod* (d a b)
(%cpy d a)
(%mod d b))
 
(defun %and* (d a b)
(%cpy d a)
(%and d b))
 
(defun %or* (d a b)
(%cpy d a)
(%or d b))
 
(defun %incr (reg)
(%add reg $one))
 
(defun %decr (reg)
(%sub reg $one))
 
(defun labeltest ()
(let ((label (gensym "IF-")))
(make-integer 10 #x5)
(make-label (intern (format nil "~A" label) (find-package "KEYWORD")))))
 
#|
;; Another simple test function
;; Suppose to be used to define the real API the assembler will have
(defun test-set2 ()
(with-assembly ("/tmp/microcode" :output-format :simulator :simulator-lines 100)
(make-integer 3 4)
(make-integer 4 4)
(when= (3 4)
(make-integer 5 4))
(when!= (3 4)
(make-integer 6 4))))
|#
;; Make microcode instruction functions
(setup-assembler)
/microprogram_assembler/mem.lisp
0,0 → 1,166
(in-package #:sexptomem)
 
(sexp-to-memory
(%nil
%t
%if
%quote
%lambda
%progn
%cons
%car
%cdr
%eval
%apply
%type
%make-array
%array-size
%array-get
%array-set
%make-symbol
%symbol-to-string
%char-to-int
%int-to-char
%get-char
%put-char
%num-devices
%device-type
%set-address
%get-address
%error
%add
%sub
%mul
%div
%bitwise-and
%bitwise-or
%bitwise-not
%bitwise-shift
%current-environment
%make-eval-state
%eval-partial
%define
%undefine
%eq?
%num-eq?
%char-eq?
%less-than?
%mod
%set!
%set-car!
%set-cdr!
 
%phase-eval
%phase-eval-args
%phase-apply
%phase-eval-if
%phase-initial
%phase-env-lookup
%phase-env-lookup-local
%phase-apply-function
%phase-bind-args
%phase-eval-progn
%phase-eval-args-top
%phase-eval-args-cdr
%phase-eval-args-cons
%phase-eval-symbol
%phase-set!
 
xxx3F
 
%timeout
%err-invalid-phase
%err-unbound-symbol
%err-invalid-param-list
%err-too-few-args
%err-too-many-args
%err-invalid-state
%err-invalid-arg-list
%err-type-error
%err-not-a-list
%err-not-a-function
%err-invalid-function
%err-malformed-form
%err-invalid-builtin
%err-invalid-array-index
%err-invalid-env
%err-not-a-pair)
:1000
(%progn
(%define (%quote =) (%lambda (a b) (%num-eq? a b)))
(%define (%quote -) (%lambda (a b) (%sub a b)))
(%define (%quote +) (%lambda (a b) (%add a b)))
(%define (%quote *) (%lambda (a b) (%mul a b)))
 
;; (%define (%quote print-string)
;; (%lambda (str devnr)
;; (%progn
;; (%define (%quote iter)
;; (%lambda (n) (%if (= n (%array-size str))
;; %nil
;; (%progn
;; (%put-char devnr (%array-get str n))
;; (iter (+ n 1))))))
;; (iter 0))))
 
(%put-char 1 #\h)
(%put-char 1 #\e)
(%put-char 1 #\l)
(%put-char 1 #\l)
(%put-char 1 #\o)
(%put-char 1 #\Newline)
 
(%define (%quote count)
(%lambda (a b)
(%progn
(%define (%quote iter)
(%lambda (n)
(%if (= n b) n (iter (+ n 1)))))
(iter a))))
 
;; (count 0 #x1000000)
 
 
(%define (%quote echo)
(%lambda (devnr)
(%progn (%put-char devnr (%get-char devnr)) (echo devnr))))
;; (echo 1)
 
(%define (%quote a) (%make-array 5 2))
 
(%array-get a 0)
(%array-set a 1 (+ (%array-get a 0)
(%array-get a 1)))
(%array-set a 1 (+ (%array-get a 0)
(%array-get a 1)))
(%define (%quote r) %nil)
(%set! (%quote r) 2)
(%define
(%quote fact)
(%lambda (n) (%if (= n 1) 1 (* n (fact (- n 1))))))
(%set! (%quote r) (fact (- 12 (* (+ 3 1) 2))))
(%set! (%quote r) (%array-get a 1))
(%set! (%quote r) (%cons r a))
;;(%error (%quote foo))
 
;;(%define (%quote foo) (%lambda (a . foo) foo))
(%set! (%quote r) (foo 1 2 3))
 
r))
 
;; (%add 2 3)
;; (%eval-partial
;; (%make-eval-state (%quote (%add 11 5))
;; (%current-environment))
;; 0)
;; (%apply
;; (%lambda (p n) (%apply p (%cons p (%cons n %nil))))
;; (%cons (%lambda (p n)
;; (%if (%num-eq? n 1)
;; 1
;; (%mul n (%apply p (%cons p (%cons (%sub n 1) %nil))))))
;; (%cons 4 %nil)))
;; (%apply (%lambda (a b) (%add a (%mul b 2))) (%quote (4 5))))
 
;; (sexp-to-memory
;; (%if nil (%add 5 2) 3))
/microprogram_assembler/mc.lisp
0,0 → 1,89
;; veldig rask skisse til del av mikrokoden, med haugevis av mer eller
;; mindre dumme antagelser om hva som er tilgjengelig i språket
 
;; registers: pc, car/cdr, data/data-ext, state, stack-top, stack-op-start, op
 
(defconst state-value 0)
(defconst state-arglist 0)
(defconst state-apply 0)
 
(defconst op-none 0)
(defconst op-+ 1)
 
(defconst evaluation-start-address 0)
 
(init)
(main)
 
(defmcop init
(mov stack-top stack-op-start)
(imm-mov evaluation-start-address pc)
(mov pc car)
(imm-mov op-none op)
(imm-mov value state))
 
(defmcop main
(imm-eq? state-value state)
(callt eval-value)
(imm-eq? state-arglist state)
(callt eval-arglist)
(imm-eq? state-apply state)
(callt apply-primitive)
(jmp main))
 
(defmcop eval-value
(load-double car data)
(is-pair? data)
(callf eval-atom)
(callt eval-pair))
 
(defmcop eval-atom
(push data) ;; assume all atoms are self-evaluating
(imm-mov state-arglist state))
 
(defmcop eval-pair
(push pc)
(push op)
(mov stack-top stack-op-start)
(mov-double data car)
(load car data)
(mov data op)
(imm-mov state-arglist state))
 
 
(defmcop eval-arglist
(is-nil? cdr)
(imm-jmpt at-end-of-list)
(mov cdr pc)
(load-double pc car)
(imm-mov state-value state)
(return)
(label at-end-of-list)
(imm-mov state-apply state))
 
 
(defmcop apply-primitive
(imm-eq? op-+ op)
(callt primitive-+)
(jmpt apply-primitive-end)
;; more ops
 
(label apply-primitive-end)
(pop op)
(pop pc)
(push data)
(imm-eq? op-none op)
(callt happy-happy-joy-joy)
(imm-mov state-arglist state)
(load-double pc car))
 
 
(defmcop primitive-+
(pop data)
(label primitive-+-loop)
(> stack-top stack-op-start)
;; todo
)
 
(defmcop happy-happy-joy-joy
(halt))
/microprogram_assembler/gc-micro.lisp
0,0 → 1,361
;; needed variables (registers) for gc
 
;; register values that must be predefined
;; set these when testing gc standalone in emulator
(defreg gc-maxblocks #x70) ;; total memory size
(defreg gc-spaces #x71) ;; number of spaces we'll divide the memory in
(defreg gc-startofmem #x76) ;; start of variable address space
 
;; registers set by evaluator before invoking gc
;; set these when testing gc standalone in emulator
(defreg gc-rootptr #x78) ;; pointer to topmost object! hopefully
;; there will be only one
 
;; registers set by init, keep these throughout
(defreg gc-spacesize #x72) ;; size of each space: maxblocks / spaces
(defreg gc-sup #x73) ;; first address beyond legal space:
;; spaces * spacesize (NB: can be lower than
;; maxblocks)
(defreg gc-gcspace #x74) ;; start of gc exclusize space, sup - spacesize
 
;; registers used by everyone
(defreg gc-firstfree #x75) ;; first free memory block
;; (might exist already in other microcode)
 
;; scratch registers, can be used when gc is not running (but gc will
;; destroy them)
 
(defreg gc-1 #x80) ;; temp
(defreg gc-vi #x83)
(defreg gc-t #x84) ;; ptr-rev
(defreg gc-x #x85) ;; ptr-rev
(defreg gc-y #x86) ;; ptr-rev
(defreg gc-v #x87) ;; ptr-rev
(defreg gc-followp #x88) ;; ptr-rev
(defreg gc-cannext #x89) ;; ptr-rev
(defreg gc-canprev #x8a) ;; ptr-rev
 
(defreg gc-temp #x8b)
(defreg gc-mem #x8c)
(defreg gc-from #x84) ;; at this stage we're no longer using
(defreg gc-to #x85) ;; some of the above variables
(defreg gc-val #x86)
(defreg gc-temp2 #x87)
 
;;(def-gc free #x00) ;; eirik must do eirik-magic to make
;;(def-gc used #x01) ;; these work as i want to
(defparameter +gc-free+ #x00)
(defparameter +gc-used+ #x01)
 
;; initialization of gc
;; call this before evaluator is run for the first time
 
(defun write-microprogram (&key (output-format :simulator))
(with-assembly ("/tmp/microcode" :output-format output-format)
:gc-init
 
;; for testing, delete later
(%set-datum-imm $one 1)
(%set-type-imm $one +type-int+)
(%set-datum-imm $zero 0)
(%set-type-imm $zero +type-int+)
 
;; temporarily commented out for testing, as this is set via register file
;; MAGIC CONSTANTS, define max memory size here
;; (%set-datum-imm $gc-maxblocks (* 1048576 2))
;; (%set-type-imm $gc-maxblocks +type-int+)
 
;; number of spaces
;; (%set-datum-imm $gc-spaces 10)
;; (%set-type-imm $gc-spaces +type-int+)
 
;; set start of gcspace (allowed heap space)
;; (%set-datum-imm $gc-firstfree 123) ;; TODO replace with proper number
;; (%set-type-imm $gc-firstfree +type-int+)
 
 
 
;; calculate spacesize
(%div* $gc-spacesize $gc-maxblocks $gc-spaces)
 
;; find maximal address + 1 (sup)
(%mul* $gc-sup $gc-spaces $gc-spacesize)
 
;; find start of gcspace
(%sub* $gc-gcspace $gc-sup $gc-spacesize)
 
 
;; do not want to ret while testing
;; (ret)
 
;; garbagecollect - the entry point
 
:gc-garbagecollect
;; mark everything as free
(%cpy $gc-vi $gc-startofmem)
 
 
:gc-loop1
;; load the contents of memory address (contained in gc-vi)
;; into register gc-1)
;; loop tested in emu: OK
(%load $gc-1 $gc-vi 0)
(%set-gc-imm $gc-1 +gc-free+)
(%store $gc-1 $gc-vi 0)
(%add $gc-vi $one)
(%cmp-datum $gc-vi $gc-gcspace)
(branchimm-false :gc-loop1)
 
;; pointer reversal! skrekk og gru
;; algorithm based on tiger book
 
;; start of pointer reversal
;; the algorithm is able to "slide" sideways without reversing
;; underlying pointers within the following structures
;; CONS - SNOC
;; ARRAY - PTR - ... - PTR - SNOC
 
;; CONS/ARRAY are identified as start of structure
;; SNOC is identified as end of structure
 
(%set-type-imm $gc-t +type-int+)
(%set-datum-imm $gc-t 0)
(%cpy $gc-x $gc-rootptr)
 
 
:gc-mainreverseloop
 
;; visit current block
;; gc-x holds current memory address
;; gc-y will hold the contents of the address
;; address 0x14
(%load $gc-y $gc-x 0)
(%set-gc-imm $gc-y +gc-used+)
(%store $gc-y $gc-x 0)
 
(%cpy $gc-followp $zero)
(%cpy $gc-cannext $zero)
(%cpy $gc-canprev $zero)
 
;; if memory address x contains a pointer, and it points to
;; a memory address marked as gc-free (ie. unvisited so far)
;; set followp to true (1)
;; the following types have pointers: CONS PTR SNOC
;; tested OK for case: cell is pointer, cell pointed to is unvisited
(%cmp-type-imm $gc-y +type-cons+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-snoc+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-ptr+)
(branchimm :gc-setfollowp)
;; if any other types contain pointers, add them here!
(jump-imm :gc-afterfollowp)
 
:gc-setfollowp
 
; copy from memory location $gc-y, into $gc-v
(%load $gc-v $gc-y 0)
(%cmp-gc-imm $gc-v +gc-used+)
(branchimm :gc-afterfollowp)
(%cpy $gc-followp $one)
 
:gc-afterfollowp
 
;; if we aren't at the last position of a memory structure spanning
;; several addresses and the next adress is free, set cannext=1
;; currently, these types can occur at the non-end: CONS, ARRAY, PTR
;; tested OK for case: cell is not end of structure, next cell is unvisited
(%cmp-type-imm $gc-y +type-cons+)
(branchimm :gc-setcannext)
(%cmp-type-imm $gc-y +type-array+)
(branchimm :gc-setcannext)
(%cmp-type-imm $gc-y +type-ptr+)
(branchimm :gc-setcannext)
(jump-imm :gc-aftercannext)
:gc-setcannext
(%cpy $gc-1 $gc-x) ;; check is address x+1 is unvisited
(%add $gc-1 $one)
(%load $gc-1 $gc-1 0) ;; lykkebo says this is safe
(%cmp-gc-imm $gc-1 +gc-used+)
(branchimm :gc-aftercannext)
(%cpy $gc-cannext $one)
 
:gc-aftercannext
 
;; if we aren't at the first position of a memory structure spanning
;; several addresses, set canprev=1
;; the following types can occur at the non-start: SNOC PTR
;; tested OK for case: cell is not end of structure
(%cmp-type-imm $gc-y +type-snoc+)
(branchimm :gc-setcanprev)
(%cmp-type-imm $gc-y +type-ptr+)
(branchimm :gc-setcanprev)
(jump-imm :gc-aftercanprev)
:gc-setcanprev
(%cpy $gc-canprev $one)
 
:gc-aftercanprev
 
;; do stuff based on followp, cannext, canprev
;; follow the pointer we're at, and reverse the pointer
;; =====> addr 0x39 <======
(%cmp-datum $gc-followp $one)
(branchimm-false :gc-afterfollowedp)
(%cpy $gc-temp $gc-x)
(%load $gc-mem $gc-temp 0)
(%set-datum $gc-mem $gc-t)
(%store $gc-mem $gc-temp 0)
(%cpy $gc-t $gc-temp)
(%set-datum $gc-x $gc-y)
(jump-imm :gc-mainreverseloop)
 
:gc-afterfollowedp
 
;; move to next memory location
(%cmp-datum $gc-cannext $one)
(branchimm-false :gc-aftercouldnext)
(%add $gc-x $one)
(jump-imm :gc-mainreverseloop)
 
:gc-aftercouldnext
 
;; move to previous memory location
(%cmp-datum $gc-canprev $one)
(branchimm-false :gc-aftercouldprev)
;; address 0x48
(%sub $gc-x $one)
(jump-imm :gc-mainreverseloop)
 
:gc-aftercouldprev
 
;; all cases exhausted: follow pointer back and reverse the reversal
(%cmp-datum $gc-t $zero)
(branchimm :gc-donepointerreversal)
(%load $gc-temp $gc-t 0) ;; read from address gc-t, into gc-temp
(%cpy $gc-mem $gc-temp)
(%set-datum $gc-mem $gc-x)
(%store $gc-mem $gc-t 0) ;; restore the correct pointer in gc-t
(%cpy $gc-x $gc-t)
(%cpy $gc-t $gc-temp)
(jump-imm :gc-mainreverseloop)
 
:gc-donepointerreversal
 
;; end of pointer reversal routine, from this point on,
;; all variables marked with "ptr-rev" are free for other use
;; ========> address 0x52 <=======
 
;; find the first address that's going to be copied
(%cpy $gc-from $gc-startofmem)
(%cpy $gc-to $gc-startofmem)
:gc-findchangeloop
(%cmp-datum $gc-from $gc-gcspace)
(branchimm :gc-findnextloop)
(%load $gc-mem $gc-from 0)
(%cmp-gc-imm $gc-mem +gc-free+)
(branchimm :gc-findnextloop)
(%add $gc-from $one)
(%add $gc-to $one)
(jump-imm :gc-findchangeloop)
:gc-findnextloop
;; we found the first hole, find the next element
(%cmp-datum $gc-from $gc-gcspace)
(branchimm :gc-copyloop)
(%load $gc-mem $gc-from 0)
(%cmp-gc-imm $gc-mem +gc-used+)
(branchimm :gc-copyloop)
(%add $gc-from $one)
(jump-imm :gc-findnextloop)
 
;; copy the stuff
;; address 0x63
 
:gc-copyloop
 
(%load $gc-mem $gc-from 0) ;; read from gc-from into gc-mem
(%cmp-gc-imm $gc-mem +gc-used+)
(branchimm-false :gc-notrans)
;; put address in translation table
(%cpy $gc-temp $gc-mem)
(%div* $gc-mem $gc-from $gc-spacesize)
(%mul $gc-mem $gc-spacesize)
(%cpy $gc-temp2 $gc-from)
(%sub $gc-temp2 $gc-mem)
(%add $gc-temp2 $gc-gcspace)
(%store $gc-to $gc-temp2 0) ;; write to-address to gc-temp2
;; copy
(%load $gc-mem $gc-from 0)
(%store $gc-temp $gc-to 0)
(%add $gc-to $one)
:gc-notrans
(%add $gc-from $one)
 
(%div* $gc-temp $gc-from $gc-spacesize)
(%mul $gc-temp $gc-spacesize)
(%sub* $gc-temp2 $gc-from $gc-temp)
(%cmp-datum $gc-temp2 $zero)
(branchimm-false :gc-noconvert)
 
;; translate pointers
;; address 0x79
:gc-transloop
(%cpy $gc-vi $gc-startofmem)
:gc-transloop2
(%load $gc-mem $gc-vi 0) ;; read from address gc-i and put into gc-mem
(%cmp-gc-imm $gc-mem +gc-used+)
(branchimm-false :gc-nexttrans)
(%cmp-type-imm $gc-mem +type-ptr+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-cons+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-snoc+)
(branchimm :gc-isptr)
(jump-imm :gc-nexttrans)
 
:gc-isptr
;; check that these branches work
;; OK for mem>=from-spacesize og mem<from
(%sub* $gc-temp $gc-from $gc-spacesize)
(%cmp-datum $gc-mem $gc-temp)
(%branch* $zero :gc-nexttrans N)
(%cmp-datum $gc-mem $gc-from)
(%branch* $zero :gc-nexttrans (not N))
 
;; TODO replace the following section whenever (if) we get a
;; modulo instruction!
 
;; calculate gcspace+val%spacesize, put in val
(%cpy $gc-val $gc-mem)
(%div* $gc-temp $gc-val $gc-spacesize)
(%mul $gc-temp $gc-spacesize)
(%sub* $gc-temp2 $gc-val $gc-temp)
(%add* $gc-val $gc-temp2 $gc-gcspace)
(%load $gc-temp2 $gc-val 0)
(%set-datum $gc-mem $gc-temp2)
(%store $gc-mem $gc-vi 0)
 
:gc-nexttrans
(%add $gc-vi $one)
(%cmp $gc-vi $gc-to)
(branchimm-false :gc-noto)
(%cpy $gc-vi $gc-from)
:gc-noto
(%cmp $gc-vi $gc-gcspace)
(branchimm-false :gc-transloop2)
 
:gc-noconvert
 
(%cmp-datum $gc-from $gc-gcspace)
(branchimm-false :gc-copyloop)
 
;; whee, gc is finished and we have a new address where
;; free space starts
(%cpy $gc-firstfree $gc-to)
 
;; dummy-labels
:ret-error
:call-error
;; address 0x9E (as of now)
 
(ret)))
/microprogram_assembler/microprogram.lisp
0,0 → 1,2398
(in-package #:mcasm)
 
(defparameter +microprogram-version+ #x12)
 
(defun alloc-imm (sz)
(%set-datum-imm $alloc-size sz)
(alloc $alloc-size))
 
(defun alloc (sz-reg)
(%cpy $alloc-addr $gc-firstfree)
(%add $gc-firstfree sz-reg)
(%cmp-datum $gc-firstfree $gc-mem-limit)
;; TODO
)
 
(defun %store-typed (datum-reg addr-reg addr-imm type)
(%set-type-imm $car type)
(%set-datum $car datum-reg)
(%store $car addr-reg addr-imm))
 
(defun %make-obj (result-reg datum-reg type)
(alloc $one)
(%store-typed datum-reg $alloc-addr 0 type)
(%set-datum result-reg $alloc-addr))
 
(defun %make-char (result-reg datum-reg)
(with-new-label ("make-char-const" constant-char)
(with-new-label ("make-char-non-const" non-constant-char)
(%set-datum-imm result-reg %area-chars)
(%add result-reg datum-reg)
(with-force-label (non-constant-char)
(%cmp-datum-imm datum-reg +constant-chars+)
(%branch* $zero non-constant-char (not N))
(%cmp-datum-imm datum-reg 0)
(%branch* $zero non-constant-char N))
(jump-imm constant-char)
(make-label non-constant-char)
(%make-obj result-reg datum-reg +type-char+)
(make-label constant-char))))
 
(defun %make-int (result-reg datum-reg)
(with-new-label ("make-int-const" constant-int)
(with-new-label ("make-int-non-const" non-constant-int)
(%set-datum-imm result-reg %area-ints)
(%add result-reg datum-reg)
(with-force-label (non-constant-int)
(%cmp-datum-imm datum-reg +constant-ints+)
(%branch* $zero non-constant-int (not N))
(%cmp-datum-imm datum-reg 0)
(%branch* $zero non-constant-int N))
(jump-imm constant-int)
(make-label non-constant-int)
(%make-obj result-reg datum-reg +type-int+)
(make-label constant-int))))
 
(defun %load-typed (result-reg addr-reg addr-imm type err-handler)
(%load result-reg addr-reg addr-imm)
(%cmp-type-imm result-reg type)
(branchimm-false err-handler))
 
(defun %cons (result-reg car-reg cdr-reg)
(%set-type-imm $car +type-cons+)
(%set-type-imm $cdr +type-snoc+)
(%set-datum $car car-reg)
(%set-datum $cdr cdr-reg)
(alloc $two)
(%store $car $alloc-addr 0)
(%store $cdr $alloc-addr 1)
(%set-datum result-reg $alloc-addr))
 
(defun %car (result-reg cons-reg err-handler)
(%load result-reg cons-reg 0)
(%cmp-type-imm result-reg +type-cons+)
(branchimm-false err-handler))
 
(defun %cdr (result-reg cons-reg err-handler)
;; TODO should check that cons-reg actually points to a cons
;; cell
(%load result-reg cons-reg 1)
(%cmp-type-imm result-reg +type-snoc+)
(branchimm-false err-handler))
 
(defun call (addr)
(with-new-label ("call" return-addr)
(%cmp-datum-imm $mc-stack-top $mc-stack-max)
(branchimm :call-error)
(let ((return-addr return-addr))
(force-label return-addr)
(%set-datum-imm (indirect-register $mc-stack-top) return-addr))
(%add $mc-stack-top $one)
(jump-imm addr)
(make-label return-addr)))
 
(defun ret ()
(%cmp-datum-imm $mc-stack-top $mc-stack-min)
(branchimm :ret-error)
(%sub $mc-stack-top $one)
(jump-reg (indirect-register $mc-stack-top)))
 
(defun %error-imm (error-type)
(%set-datum-imm $car %error)
(%set-datum-imm $cdr error-type)
(%cons $s-condition $car $cdr)
(%set-datum-imm $mc-stack-top $mc-stack-min)
(call :interrupt)
(jump-imm :main-loop-end))
 
(defun %error (error-type-reg)
(%set-datum-imm $car %error)
(%cons $s-condition $car error-type-reg)
(%set-datum-imm $mc-stack-top $mc-stack-min)
(call :interrupt)
(jump-imm :main-loop-end))
 
(defun select-device (devnr-reg)
(%when-not (%cmp-datum $io-devnr devnr-reg)
(%cpy $io-devnr devnr-reg)
(%store $io-devnr $io-mem-addr %io-curdev)))
 
(defun select-device-imm (devnr)
(%when-not (%cmp-datum-imm $io-devnr devnr)
(%set-datum-imm $io-devnr devnr)
(%store $io-devnr $io-mem-addr %io-curdev)))
 
(defun message (msg-reg) ; output a char from a register
(select-device-imm +dev-serial+)
(%store msg-reg $io-mem-addr %io-object))
 
(defun message-reg-no-nl (reg)
(%set-datum $message reg)
(call :message-reg))
 
(defun message-reg (reg) ; output an integer from a register
(message-reg-no-nl reg)
(message-imm #\Return)
(message-imm #\Newline))
 
(defun message-imm (msg) ; output an immediate character
(%set-type-imm $message +type-char+)
(%set-datum-imm $message (char-int msg))
(message $message))
 
(defun message-str-no-nl (str)
(%set-type-imm $message +type-char+)
(select-device-imm +dev-serial+)
(loop for ch across str do
(%set-datum-imm $message (char-int ch))
(%store $message $io-mem-addr %io-object)))
 
(defun message-str (str)
(message-str-no-nl str)
(message-imm #\Return)
(message-imm #\Newline))
 
(defun e-expr () (indirect-register $e-expr))
(defun e-arg () (indirect-register $e-arg))
(defun e-result () (indirect-register $e-result))
(defun e-phase () (indirect-register $e-phase))
 
(defun push-eframe ()
(with-new-label ("push-eframe-free-frame" push-eframe-free-frame)
(%add $e-expr $e/f-frame-size)
(%add $e-arg $e/f-frame-size)
(%add $e-result $e/f-frame-size)
(%add $e-phase $e/f-frame-size)
 
;; new frame in use or above top?
(%cmp-type-imm (indirect-register $e-expr) +type-none+)
;; if so, call the subroutine to handle such cases
(branchimm push-eframe-free-frame)
(call :push-eframe-handle-overflow)
(make-label push-eframe-free-frame)
 
(%set-type-imm (e-expr) +type-cons+)
(%set-datum-imm (e-arg) %nil)
(%set-datum-imm (e-result) %nil))) ; caller must set $e-expr, $e-phase
 
(defun pop-eframe ()
(with-new-label ("pop-eframe-start" pop-eframe-start)
(with-new-label ("pop-eframe-non-empty-frame" pop-eframe-non-empty-frame)
(with-new-label ("pop-eframe-not-func-frame" pop-eframe-not-func-frame)
(make-label pop-eframe-start)
(%set-type-imm (indirect-register $e-expr) +type-none+)
 
(%sub $e-expr $e/f-frame-size)
(%sub $e-arg $e/f-frame-size)
(%sub $e-result $e/f-frame-size)
(%sub $e-phase $e/f-frame-size)
 
;; is this frame empty or below bottom?
(%cmp-type-imm (indirect-register $e-expr) +type-none+)
(branchimm-false pop-eframe-non-empty-frame)
(call :pop-eframe-handle-underflow)
(make-label pop-eframe-non-empty-frame)
 
(%cmp-type-imm (indirect-register $e-expr) +type-function+)
(branchimm-false pop-eframe-not-func-frame)
(%set-datum $f-func (indirect-register $e-expr))
(%set-datum $f-env (indirect-register $e-arg))
(jump-imm pop-eframe-start)
(make-label pop-eframe-not-func-frame)))))
 
 
 
(defun write-microprogram (&key (output-format :simulator))
(with-assembly ("/tmp/microcode" :output-format output-format)
:init
 
;; I/O init:
(%load $io-devnr $io-mem-addr %io-curdev)
 
(message-str (format nil "IGOREV INIT v. 0x~X" +microprogram-version+))
 
 
;; write initial data to memory:
 
;; nil/t/symbols, strings:
(%store $init1 $zero %nil)
 
;; (message-str "READ NIL,")
;; (%load $tmp1 $zero %nil)
;; (message-reg $tmp1)
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
(%store $init2 $zero 1)
(%set-type-imm $init1 +type-ptr+)
(%set-type-imm $init2 +type-ptr+)
(%set-type-imm $init3 +type-ptr+)
:init-mem-symbols-loop
(%set-datum $init1 (indirect-register $init-counter))
(%shift-r $init1 $init-shift1)
(%set-datum $init2 (indirect-register $init-counter))
(%shift-r $init2 $init-shift2)
(%and $init2 $init-char-mask)
(%set-datum $init3 (indirect-register $init-counter))
(%and $init3 $init-char-mask)
(%set-type-imm (indirect-register $init-counter) 0)
(%set-datum-imm (indirect-register $init-counter) 0)
(%set-datum-imm $init-counter2 $init1)
:init-mem-symbols-loop2
(%cmp-datum-imm (indirect-register $init-counter2) 0)
(branchimm :init-mem-symbols-end-symbol)
(%add (indirect-register $init-counter2) $init-chars-start)
(%incr $init-symbol-char-addr)
(%store (indirect-register $init-counter2) $init-symbol-char-addr 0)
:init-mem-symbols-loop2-continue
(%cmp-datum-imm $init-counter2 $init3)
(branchimm :init-mem-symbols-loop2-end)
(%incr $init-counter2)
(jump-imm :init-mem-symbols-loop2)
:init-mem-symbols-end-symbol
(%store-typed $zero $init-symbol-addr 0 +type-none+) ; in case there is no symbol
(%sub* $init-symbol-array $init-symbol-char-addr $init-symbol-str-addr)
(branchimm
:init-mem-symbols-end-symbol-next) ; if there are no characters,
; just skip to the next symbol
(%set-type-imm $init-symbol-array +type-array+)
(%store $init-symbol-array $init-symbol-str-addr 0)
(%store $list-terminator $init-symbol-char-addr 1)
(%store-typed $init-symbol-str-addr $init-symbol-addr 0 +type-symbol+)
(%add $init-symbol-char-addr 2)
(%set-datum $init-symbol-str-addr $init-symbol-char-addr)
:init-mem-symbols-end-symbol-next
(%incr $init-symbol-addr)
(jump-imm :init-mem-symbols-loop2-continue)
:init-mem-symbols-loop2-end
(%incr $init-counter)
(%cmp-type-imm (indirect-register $init-counter) +type-int+)
(branchimm :init-mem-symbols-loop)
 
;; builtins:
(%set-type-imm $init1 +type-builtin+)
(%set-datum-imm $init1 +first-builtin+)
:init-mem-builtins-loop
(%store $init1 $init1 %area-builtins)
(%cmp-datum-imm $init1 +last-builtin+)
(branchimm :init-mem-builtins-loop-end)
(%incr $init1)
(jump-imm :init-mem-builtins-loop)
:init-mem-builtins-loop-end
 
;; characters:
(%set-type-imm $init1 +type-char+)
(%set-datum-imm $init1 0)
:init-mem-chars-loop
(%store $init1 $init1 %area-chars)
(%incr $init1)
(%cmp-datum-imm $init1 +constant-chars+)
(branchimm-false :init-mem-chars-loop)
 
;; ints:
(%set-type-imm $init1 +type-int+)
(%set-datum-imm $init1 0)
:init-mem-ints-loop
(%store $init1 $init1 %area-ints)
(%incr $init1)
(%cmp-datum-imm $init1 +constant-ints+)
(branchimm-false :init-mem-ints-loop)
 
;; symbol list:
(%set-type-imm $init1 +type-cons+)
(%set-type-imm $init2 +type-snoc+)
(%set-datum-imm $init1 2) ; init1: address of symbol
(%set-datum-imm $init2 (+ %area-symlist 2)) ; init2: address of next cons cell
:init-mem-symlist-loop
(%load $init3 $init1 0) ; init3: current symbol
(%cmp-type-imm $init3 +type-none+)
(branchimm
:init-mem-symlist-loop-continue) ; skip to next if no symbol
; (there may be gaps)
(%store $init1 $init2 -2)
(%store $init2 $init2 -1)
(%add $init2 $two)
:init-mem-symlist-loop-continue
(%incr $init1)
(%cmp-datum-imm $init1 +last-symbol+)
(branchimm-false :init-mem-symlist-loop)
(%store $init1 $init2 -2)
(%store $list-terminator $init2 -1)
 
;; memory root pointer:
(%set-type-imm $tmp1 +type-cons+)
(%set-datum-imm $tmp1 %nil)
(%store $tmp1 $zero %memory-root)
(%store $list-terminator $zero (+ %memory-root 1))
;; end memory initialization
 
;; most essential initialization:
(%set-type-imm $zero +type-int+)
(%set-datum-imm $zero 0)
 
(%set-type-imm $one +type-int+)
(%set-datum-imm $one 1)
 
(%set-type-imm $two +type-int+)
(%set-datum-imm $two 2)
 
;; (%set-type-imm $list-terminator +type-snoc+)
;; (%set-datum-imm $list-terminator 0)
 
(%set-type-imm $mc-stack-top +type-int+)
(%set-datum-imm $mc-stack-top $mc-stack-min)
 
;;(make-integer $gc-firstfree #x20000)
(%set-type-imm $alloc-size +type-int+)
(%set-type-imm $alloc-addr +type-int+)
 
;; (%set-type-imm $io-mem-addr +type-int+)
;; (%set-datum-imm $io-mem-addr #x3FFFF)
;; (%set-datum-imm $tmp1 #x8)
;; (%shift $io-mem-addr $tmp1)
;; end most essential initialization
 
 
(message-str-no-nl "BOOT: ")
:boot
(select-device-imm +dev-boot+)
(%load $tmp1 $io-mem-addr %io-size-l) ; $tmp1: boot program size
(message-reg-no-nl $tmp1) (message-str " WORDS")
(select-device-imm +dev-boot+)
;; (%cmp-datum-imm $tmp1 0) ; temporary to avoid loading boot program
;; (branchimm :boot-end)
(%set-type-imm $tmp2 +type-int+)
(%set-datum-imm $tmp2 0) ; $tmp2: address counter
(%store $tmp2 $io-mem-addr %io-addr-l)
:boot-loop
(%set-datum-imm $tmp4 #xFF)
(%and $tmp4 $tmp2)
(%cmp-datum-imm $tmp4 0)
(branchimm-false :boot-loop-no-print)
(message-reg-no-nl $tmp2)
(message-imm #\Return)
(select-device-imm +dev-boot+)
:boot-loop-no-print
 
(%load $tmp3 $io-mem-addr %io-object)
(%store $tmp3 $tmp2 %boot-prog-start)
(%incr $tmp2)
;;(message-reg $tmp2) (select-device-imm +dev-boot+)
(%cmp-datum $tmp2 $tmp1)
(branchimm-false :boot-loop)
(%set-datum-imm $gc-firstfree %boot-prog-start)
(%add $gc-firstfree $tmp2)
:boot-end
(message-str "COMPLETE")
 
;; start GC initialization
(%set-datum-imm $gc-rootptr %memory-root)
 
(%set-datum-imm $gc-startofmem (- %mem-reserved-top 2)) ; include root pointer
 
;; number of spaces
(%set-datum-imm $gc-spaces +gc-spaces+)
(%set-type-imm $gc-spaces +type-int+)
 
;; calculate spacesize
;; set this manually for now! not easy to replace div
;;(%set-datum-imm $gc-spacesize (/ (* 1048576 2) +gc-spaces+))
;; (%div* $gc-spacesize $gc-maxblocks $gc-spaces)
;; find maximal address + 1 (sup)
(%mul* $gc-sup $gc-spaces $gc-spacesize)
 
;; find start of gcspace
(%sub* $gc-gcspace $gc-sup $gc-spacesize)
 
(%set-datum-imm $tmp1 +gc-limit+)
(%sub* $gc-mem-limit $gc-gcspace $tmp1)
;; end GC initialization
 
 
;; initialize evaluation stacks:
(%set-datum-imm $e/f-frame-size 4)
(%set-type-imm $e/f-below-marker +type-none+)
(%set-type-imm $e/f-above-marker +type-cons+)
 
(%set-datum-imm $tmp1 $e/f-min)
:clear-e/f-loop
(%set-type-imm (indirect-register $tmp1) +type-none+)
(%set-datum-imm (indirect-register $tmp1) 0)
(%add $tmp1 $one)
(%cmp-datum-imm $tmp1 $e/f-max)
(branchimm-false :clear-e/f-loop)
 
(call :init-evaluation-level)
 
;; set current expression and environment to boot program's
;; expression and environment:
(%set-datum-imm $tmp1 %boot-prog-start)
(%car (e-expr) $tmp1 :err-not-a-pair)
(%cdr $f-env $tmp1 :err-not-a-pair)
(%set-datum-imm (e-phase) %phase-eval)
 
 
 
;; (message-str "NIL IS ")
;; (%load $tmp1 $zero %nil)
;; (message-reg $tmp1)
;; (message-str "TYPE ")
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
;; (message-str "T IS ")
;; (%load $tmp1 $zero 1)
;; (message-reg $tmp1)
;; (message-str "TYPE ")
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
;; (message-str "IF IS ")
;; (%load $tmp1 $zero 2)
;; (message-reg $tmp1)
;; (message-str "TYPE ")
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
;; (message-str "CONS IS ")
;; (%load $tmp1 $zero 6)
;; (message-reg $tmp1)
;; (message-str "TYPE ")
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
;; (message-str "PHASE-EVAL IS ")
;; (%load $tmp1 $zero #x40)
;; (message-reg $tmp1)
;; (message-str "TYPE ")
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
;; (message-str "CONS FUNCTION IS ")
;; (%load $tmp1 $zero #x106)
;; (message-reg $tmp1)
;; (message-str "TYPE ")
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
 
 
 
:main-loop
 
;; check that phase is valid:
(%cmp-datum-imm (e-phase) +first-phase+)
(%branch* $zero :err-invalid-phase N)
(%cmp-datum-imm (e-phase) (+ +last-phase+ 1))
(%branch* $zero :err-invalid-phase (not N))
 
;;dispatch:
(let ((label :phase-dispatch-table))
(force-label label)
(jump (e-phase) (- label +first-phase+)))
 
:phase-dispatch-table
(jump-imm :p-eval)
(jump-imm :p-eval-args)
(jump-imm :p-apply)
(jump-imm :p-eval-if)
(jump-imm :p-initial)
(jump-imm :p-env-lookup)
(jump-imm :p-env-lookup-local)
(jump-imm :p-apply-function2)
(jump-imm :p-bind-args)
(jump-imm :p-eval-progn)
(jump-imm :p-eval-args-top)
(jump-imm :p-eval-args-cdr)
(jump-imm :p-eval-args-cons)
(jump-imm :p-eval-symbol)
(jump-imm :p-set!)
 
 
;; PHASE: EVAL
 
:p-eval
(%load $car (e-expr) 0)
(%cmp-type-imm $car +type-cons+)
(branchimm :p-eval-form)
(%cmp-type-imm $car +type-symbol+)
(branchimm :p-eval-symbol1)
:p-eval-self-evaluating
(%cpy $tmp1 (e-expr))
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
 
:p-eval-symbol1
(%cmp-datum-imm (e-expr) +first-magic-var+)
(%branch* $zero :p-eval-symbol1-regular-var N)
(%cmp-datum-imm (e-expr) (+ +last-magic-var+ 1))
(%branch* $zero :p-eval-symbol1-regular-var (not N))
 
:p-eval-symbol1-magic-var
(%set-datum-imm $tmp1 %area-builtins)
(%add $tmp1 (e-expr))
(pop-eframe)
(%set-datum (e-result) $tmp1)
;; (%when (%cmp-datum-imm (e-expr) %symbol-table)
;; (%set-datum-imm (e-result) %area-symlist))
(jump-imm :main-loop-end)
 
:p-eval-symbol1-regular-var
(%set-datum $tmp1 (e-expr))
(%set-datum-imm (e-phase) %phase-eval-symbol)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum (e-arg) $f-env)
(%set-datum-imm (e-phase) %phase-env-lookup)
(jump-imm :main-loop-end)
 
 
:p-eval-form
(%load $car (e-expr) 0)
(%load $cdr (e-expr) 1)
(%cmp-datum-imm $car %quote)
(branchimm :p-eval-form-quote)
(%cmp-datum-imm $car %if)
(branchimm :p-eval-form-if)
(%cmp-datum-imm $car %lambda)
(branchimm :p-eval-form-lambda)
(%cmp-datum-imm $car %progn)
(branchimm :p-eval-progn1)
 
:p-eval-form-function
(%set-datum-imm (e-phase) %phase-eval-args-top)
(%set-datum $tmp1 $car)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
 
:p-eval-form-quote
(%set-datum $tmp1 $cdr)
(pop-eframe)
(%load $car $tmp1 0)
(%set-datum (e-result) $car)
(jump-imm :main-loop-end)
 
:p-eval-form-lambda ; (%lambda name param-list expr)
;; TODO check args
;; TODO take name as additional argument
(%car $tmp1 $cdr :err-not-a-list) ; $tmp1: name
(%cdr $cdr $cdr :err-not-a-list) ; $cdr: (param-list expr)
(%car $tmp2 $cdr :err-not-a-list) ; $tmp2: param-list
(%cdr $cdr $cdr :err-not-a-list) ; $cdr: (expr)
(%car $tmp3 $cdr :err-not-a-list) ; $tmp3: expr
(%cdr $cdr $cdr :err-not-a-list)
(%cmp-datum-imm $cdr %nil)
(branchimm-false :err-too-many-args)
(%cons $tmp4 $f-env $list-terminator) ; $tmp4: (env)
(%cons $tmp4 $tmp3 $tmp4) ; $tmp4: (expr env)
(%cons $tmp4 $tmp2 $tmp4) ; $tmp4: (param-list expr env)
(%cons $tmp4 $tmp1 $tmp4) ; $tmp4: (name param-list expr env)
(%make-obj $tmp1 $tmp4 +type-function+) ; $tmp1: function (address)
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
:p-eval-form-if ; (%if test a b)
(%load $tmp1 $cdr 0)
;;(%load $cdr $cdr 1)
(%set-datum-imm (e-phase) %phase-eval-if)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
 
 
;; PHASE: EVAL-IF
 
:p-eval-if ; (%if test a b) caddr, cadddr
(%load $cdr (e-expr) 1)
(%load $cdr $cdr 1) ;; cddr
(%cmp-datum-imm (e-result) %nil)
(branchimm-false :p-eval-if-true)
(%load $cdr $cdr 1) ;; cdddr
:p-eval-if-true
(%load $car $cdr 0) ;; caddr/cadddr
(%set-datum (e-expr) $car)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
 
 
;; PHASE: EVAL-PROGN
 
:p-eval-progn1 ; this first part belongs to EVAL phase
(%set-datum (e-arg) $cdr)
(%set-datum-imm (e-result) %nil)
(%set-datum-imm (e-phase) %phase-eval-progn)
:p-eval-progn ; (%progn form ...)
(%cmp-datum-imm (e-arg) %nil)
(branchimm :p-eval-progn-empty)
(%car $tmp1 (e-arg) :err-not-a-list) ; $tmp1: first argument
(%cdr (e-arg) (e-arg) :err-not-a-list)
(%cmp-datum-imm (e-arg) %nil)
(branchimm :p-eval-progn-last)
;; more than one argument:
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
:p-eval-progn-empty ; no arguments
(pop-eframe)
(%set-datum-imm (e-result) %nil)
(jump-imm :main-loop-end)
:p-eval-progn-last ; exactly one argument, eval it in this eframe
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-arg) %nil)
(%set-datum-imm (e-result) %nil)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
 
 
;; PHASE: EVAL-SYMBOL
 
:p-eval-symbol
(%cmp-datum-imm (e-result) %nil)
(branchimm :err-unbound-symbol)
(%cdr $tmp1 (e-result) :err-invalid-state)
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
 
;; PHASES: EVAL-ARGS, EVAL-ARGS-{TOP,CDR,CONS}
 
:p-eval-args-top
(%set-datum (e-arg) (e-result)) ; copy function pointer to (e-arg)
(%set-datum-imm (e-phase) %phase-apply)
(%cdr $tmp1 (e-expr) :err-malformed-form)
(push-eframe)
(%set-datum-imm (e-phase) %phase-eval-args)
(%set-datum (e-expr) $tmp1)
(jump-imm :main-loop-end)
 
:p-eval-args
(%cmp-datum-imm (e-expr) %nil)
(branchimm :p-eval-args-empty-list)
(%car $tmp1 (e-expr) :p-eval-args-error)
(%set-datum-imm (e-phase) %phase-eval-args-cdr)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
:p-eval-args-empty-list
(pop-eframe)
(%set-datum-imm (e-result) %nil)
(jump-imm :main-loop-end)
;; (%set-datum (e-arg) (e-result))
;; (%load $cdr (e-expr) 1)
;; (%cmp-datum-imm $cdr %nil)
;; (branchimm :p-apply1)
;; (%load $cdr $cdr 1)
;; (%load $car $cdr 0)
;; (%set-datum-imm (e-phase) %phase-apply)
;; (call :push-e)
;; (%set-datum (e-expr) $car)
;; (jump-imm :main-loop-end)
 
:p-eval-args-cdr
(%set-datum (e-arg) (e-result))
(%cdr $tmp1 (e-expr) :p-eval-args-error)
(%set-datum-imm (e-phase) %phase-eval-args-cons)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval-args)
(jump-imm :main-loop-end)
 
:p-eval-args-cons
(%cons $tmp1 (e-arg) (e-result))
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
:p-eval-args-error ; common to p-eval-args, p-eval-args-cdr, p-eval-args-cons
(%error %err-invalid-arg-list)
 
 
;; PHASE: ENV-LOOKUP
 
:p-env-lookup
;; (e-expr): variable name (address)
;; (e-arg): env (address)
(%cmp-datum-imm (e-result) %nil)
(branchimm-false :p-env-lookup-ret)
(%cmp-datum-imm (e-arg) %nil)
(branchimm :p-env-lookup-ret)
;;(branchimm :err-unbound-symbol)
(%set-datum $tmp1 (e-expr))
(%car $tmp2 (e-arg) :err-invalid-env)
(%cdr (e-arg) (e-arg) :err-invalid-env)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum (e-arg) $tmp2)
(%set-datum-imm (e-phase) %phase-env-lookup-local)
(jump-imm :main-loop-end)
:p-env-lookup-ret
(%set-datum $tmp1 (e-result))
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
 
;; PHASE: ENV-LOOKUP-LOCAL
:p-env-lookup-local
;; (e-expr): variable name (address)
;; (e-arg): env binding list (address)
(%set-datum-imm $tmp1 %nil)
(%cmp-datum-imm (e-arg) %nil)
(branchimm :p-env-lookup-local-ret)
(%car $tmp1 (e-arg) :err-invalid-env) ; $tmp1: (symbol . value)
(%car $tmp2 $tmp1 :err-invalid-env) ; $tmp2: symbol
(%cmp-datum $tmp2 (e-expr))
(branchimm :p-env-lookup-local-ret)
(%cdr (e-arg) (e-arg) :err-invalid-env)
(jump-imm :main-loop-end)
:p-env-lookup-local-ret
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
 
;; PHASE: BIND-ARGS
 
:p-bind-args
;; (e-expr): existing bindings
;; (e-arg): (rest of) param list
;; (e-result): (rest of) arg list
(%load $params-car (e-arg) 0)
;; dispatch on type of param list:
(%cmp-type-imm $params-car +type-cons+)
(branchimm :p-bind-args-head)
(%cmp-type-imm $params-car +type-nil+)
(branchimm :p-bind-args-empty)
(%cmp-type-imm $params-car +type-symbol+)
(branchimm :p-bind-args-tail)
(jump-imm :err-invalid-param-list)
 
:p-bind-args-head
;; param list is of form (p1 . rest). check that arg list has form
;; (a1 . rest) and that p1 is actually a symbol. if so, bind p1 to
;; a1 and continue cdr-ing down both lists:
(%load $tmp1 $params-car 0)
(%cmp-type-imm $tmp1 +type-symbol+)
(branchimm-false :err-invalid-param-list)
(%load $args-car (e-result) 0)
(%cmp-type-imm $args-car +type-cons+)
(branchimm-false :err-too-few-args)
;; make a binding (p1 . a1):
(%cons $tmp1 $params-car $args-car)
;; cons the new binding on the list:
(%cons (e-expr) $tmp1 (e-expr))
;; cdr down param and arg list:
(%load (e-arg) (e-arg) 1)
(%load (e-result) (e-result) 1)
(jump-imm :main-loop-end)
 
:p-bind-args-tail
;; param list is of form p1, that is, just a single symbol; so
;; bind this to the whole arglist and return:
(%cons $tmp1 (e-arg) (e-result))
(%cons $tmp1 $tmp1 (e-expr))
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
:p-bind-args-empty
;; empty param list; check that arg list is empty too, and return:
(%cmp-datum-imm (e-result) %nil)
(branchimm-false :err-too-many-args)
(%set-datum $tmp1 (e-expr))
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
 
;; PHASE: APPLY
 
:p-apply
;; (e-arg): function (address)
;; (e-result): argument list (address)
(%load $apply-func (e-arg) 0)
(%cmp-type-imm $apply-func +type-builtin+)
(branchimm :p-apply-builtin)
(%cmp-type-imm $apply-func +type-function+)
(branchimm :p-apply-function1)
(%error-imm %err-not-a-function)
 
:p-apply-builtin ; $apply-func contains the identifier of the
; function (the adress of the symbol used for
; naming it), use this as offset into the table
; below
(%set-type-imm $builtin-arg1 +type-none+)
(%set-type-imm $builtin-arg2 +type-none+)
(%set-type-imm $builtin-arg3 +type-none+)
 
;; check builtin identifier:
(%cmp-datum-imm $apply-func +first-builtin+)
(%branch* $zero :err-invalid-builtin N)
(%cmp-datum-imm $apply-func (+ +last-builtin+ 1))
(%branch* $zero :err-invalid-builtin (not N))
 
(let ((label :p-apply-table))
(force-label label)
(jump $apply-func (- label +first-builtin+)))
:p-apply-table
(jump-imm :builtin-cons)
(jump-imm :builtin-car)
(jump-imm :builtin-cdr)
(jump-imm :builtin-eval)
(jump-imm :builtin-apply)
(jump-imm :builtin-type)
(jump-imm :builtin-make-array)
(jump-imm :builtin-array-size)
(jump-imm :builtin-array-get)
(jump-imm :builtin-array-set)
(jump-imm :builtin-make-symbol)
(jump-imm :builtin-symbol-to-string)
(jump-imm :builtin-char-to-int)
(jump-imm :builtin-int-to-char)
(jump-imm :builtin-get-char)
(jump-imm :builtin-put-char)
(jump-imm :builtin-num-devices)
(jump-imm :builtin-device-type)
(jump-imm :builtin-set-address)
(jump-imm :builtin-get-address)
(jump-imm :builtin-error)
(jump-imm :builtin-add)
(jump-imm :builtin-sub)
(jump-imm :builtin-mul)
(jump-imm :builtin-div)
(jump-imm :builtin-bitwise-and)
(jump-imm :builtin-bitwise-or)
(jump-imm :builtin-bitwise-not)
(jump-imm :builtin-bitwise-shift)
(jump-imm :builtin-current-environment)
(jump-imm :builtin-make-eval-state)
(jump-imm :builtin-eval-partial)
(jump-imm :builtin-define)
(jump-imm :builtin-undefine)
(jump-imm :builtin-eq?)
(jump-imm :builtin-num-eq?)
(jump-imm :builtin-char-eq?)
(jump-imm :builtin-less-than?)
(jump-imm :builtin-mod)
(jump-imm :builtin-set!)
(jump-imm :builtin-set-car!)
(jump-imm :builtin-set-cdr!)
(jump-imm :builtin-function-data)
(jump-imm :builtin-builtin-name)
(jump-imm :builtin-device-size)
(jump-imm :builtin-device-status)
 
:builtin-cons ; (%cons obj1 obj2)
(%set-type-imm $builtin-arg1 +type-t+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%cons $apply-result $builtin-arg1 $builtin-arg2)
(jump-imm :p-apply-end)
 
:builtin-car ; (%car cons-cell)
(%set-type-imm $builtin-arg1 +type-cons+)
(call :fetch-args)
(%set-datum $apply-result $builtin-arg1-val)
(jump-imm :p-apply-end)
 
:builtin-cdr ; (%cdr cons-cell)
(%set-type-imm $builtin-arg1 +type-cons+)
(call :fetch-args)
(%load $apply-result $builtin-arg1 1)
(jump-imm :p-apply-end)
 
:builtin-eq? ; (%eq? obj1 obj2)
(%set-type-imm $builtin-arg1 +type-t+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%set-datum-imm $apply-result %nil)
(when= ($builtin-arg1 $builtin-arg2)
(%set-datum-imm $apply-result %t))
(jump-imm :p-apply-end)
 
:builtin-type ; (%type obj)
(%set-type-imm $builtin-arg1 +type-t+)
(call :fetch-args)
(%get-type $tmp1 $builtin-arg1-val)
(%make-obj $apply-result $tmp1 +type-int+)
(jump-imm :p-apply-end)
 
:builtin-eval ; (%eval expr env)
(%set-type-imm $builtin-arg1 +type-t+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%set-datum $apply-eval-expr $builtin-arg1)
(%set-datum $apply-eval-env $builtin-arg2)
(call :push-or-reuse-fframe)
(%set-datum-imm $f-func %eval) ; should maybe have a dedicated symbol for this
(%set-datum $f-env $apply-eval-env)
(%set-datum (e-expr) $apply-eval-expr)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end) ; note: not :p-apply-end
 
:builtin-apply ; (%apply func args)
;; move stuff around and go through APPLY phase again:
(%set-type-imm $builtin-arg1 +type-t+) ; function or builtin
(%set-type-imm $builtin-arg2 +type-t+) ; list (cons or nil)
(call :fetch-args)
(%set-datum (e-arg) $builtin-arg1)
(%set-datum (e-result) $builtin-arg2)
(jump-imm :main-loop-end)
 
:builtin-make-array ; (%make-array size init-value)
(%set-type-imm $builtin-arg1 +type-int+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
;; TODO check size
(%set-datum $tmp1 $builtin-arg1-val)
(%add $tmp1 $two) ; $tmp1: words needed (array object + pointers + end marker)
(alloc $tmp1)
(%store-typed $builtin-arg1-val $alloc-addr 0 +type-array+)
(%add $tmp1 $alloc-addr)
(%decr $tmp1) ; $tmp1: address of end marker
(%set-datum $tmp2 $alloc-addr)
(%incr $tmp2) ; $tmp2: address to store pointer at
:builtin-make-array-loop
(%store-typed $builtin-arg2 $tmp2 0 +type-ptr+)
(%incr $tmp2)
(%cmp-datum $tmp2 $tmp1)
(branchimm-false :builtin-make-array-loop)
(%store-typed $zero $tmp2 0 +type-snoc+) ; end marker
(%set-datum $apply-result $alloc-addr)
(jump-imm :p-apply-end)
 
:builtin-array-size ; (%array-size array)
(%set-type-imm $builtin-arg1 +type-array+)
(call :fetch-args)
(%make-obj $apply-result $builtin-arg1-val +type-int+)
(jump-imm :p-apply-end)
 
:builtin-array-get ; (%array-get array index)
(%set-type-imm $builtin-arg1 +type-array+)
(%set-type-imm $builtin-arg2 +type-int+)
(call :fetch-args)
 
;; check index;
(%cmp-datum $builtin-arg2-val $builtin-arg1-val)
(%branch* $zero :err-invalid-array-index (not N))
(%cmp-datum $builtin-arg2-val $zero)
(%branch* $zero :err-invalid-array-index N)
 
(%add* $tmp1 $builtin-arg1 $builtin-arg2-val)
(%load $apply-result $tmp1 1)
(jump-imm :p-apply-end)
 
:builtin-array-set ; (%array-set array index value) => array
(%set-type-imm $builtin-arg1 +type-array+)
(%set-type-imm $builtin-arg2 +type-int+)
(%set-type-imm $builtin-arg3 +type-t+)
(call :fetch-args)
 
;; check index;
(%cmp-datum $builtin-arg2-val $builtin-arg1-val)
(%branch* $zero :err-invalid-array-index (not N))
(%cmp-datum $builtin-arg2-val $zero)
(%branch* $zero :err-invalid-array-index N)
 
(%add* $tmp1 $builtin-arg1 $builtin-arg2-val)
(%store-typed $builtin-arg3 $tmp1 1 +type-ptr+)
(%set-datum $apply-result $builtin-arg1)
(jump-imm :p-apply-end)
 
:builtin-make-symbol ; (%make-symbol str)
(%set-type-imm $builtin-arg1 +type-array+) ; TODO check that it is a string
(call :fetch-args)
(%make-obj $apply-result $builtin-arg1 +type-symbol+)
(jump-imm :p-apply-end)
 
:builtin-symbol-to-string ; (%symbol-to-string symb)
(%set-type-imm $builtin-arg1 +type-symbol+)
(call :fetch-args)
(%set-datum $apply-result $builtin-arg1-val)
(jump-imm :p-apply-end)
 
:builtin-char-to-int ; (%char-to-int ch)
(%set-type-imm $builtin-arg1 +type-char+)
(call :fetch-args)
(%make-int $apply-result $builtin-arg1-val)
(jump-imm :p-apply-end)
 
:builtin-int-to-char ; (%int-to-char n)
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(%make-char $apply-result $builtin-arg1-val)
;;(%make-obj $apply-result $builtin-arg1-val +type-char+)
(jump-imm :p-apply-end)
 
:builtin-char-eq? ; (%char-eq? ch1 ch2)
(%set-type-imm $builtin-arg1 +type-char+)
(%set-type-imm $builtin-arg2 +type-char+)
(call :fetch-args)
(%set-datum-imm $apply-result %nil)
(%when (%cmp-datum $builtin-arg1-val $builtin-arg2-val)
(%set-datum-imm $apply-result %t))
(jump-imm :p-apply-end)
 
:builtin-get-char ; (%get-char devnr)
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(select-device $builtin-arg1-val)
;; :builtin-get-char-read
(%load-typed $tmp1 $io-mem-addr %io-object +type-char+ :err-io-error)
;; TODO handle errors
(%make-char $apply-result $tmp1)
(jump-imm :p-apply-end)
 
;; :builtin-get-char-io-error
;; (message-str "I/O ERROR")
;; (message-reg $tmp1)
;; (%get-type $tmp2 $tmp1)
;; (message-reg $tmp2)
;; (jump-imm :builtin-get-char-read)
 
:builtin-put-char ; (%put-char devnr ch) => ch
(%set-type-imm $builtin-arg1 +type-int+)
(%set-type-imm $builtin-arg2 +type-char+)
(call :fetch-args)
(select-device $builtin-arg1-val)
(%store $builtin-arg2-val $io-mem-addr %io-object)
;; TODO handle errors
(%set-datum $apply-result $builtin-arg2)
(jump-imm :p-apply-end)
 
:builtin-num-devices ; (%num-devices)
(call :fetch-args)
(%load-typed $tmp1 $io-mem-addr %io-devices +type-int+ :err-io-error)
(%make-int $apply-result $tmp1)
(jump-imm :p-apply-end)
 
:builtin-device-type ; (%device-type devnr)
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(select-device $builtin-arg1-val)
(%load-typed $tmp1 $io-mem-addr %io-identification +type-int+ :err-io-error)
(%make-int $apply-result $tmp1)
(jump-imm :p-apply-end)
 
:builtin-set-address ; (%set-address devnr addr) => addr
;; only sets lower part of address as of now
(%set-type-imm $builtin-arg1 +type-int+)
(%set-type-imm $builtin-arg2 +type-int+)
(call :fetch-args)
(select-device $builtin-arg1-val)
(%store-typed $builtin-arg2-val $io-mem-addr %io-addr-l +type-int+)
(%set-datum $apply-result $builtin-arg2)
(jump-imm :p-apply-end)
 
:builtin-get-address ; (%get-address devnr)
;; only gets lower part of address as of now
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(select-device $builtin-arg1-val)
(%load-typed $tmp1 $io-mem-addr %io-addr-l +type-int+ :err-io-error)
(%make-int $apply-result $tmp1)
(jump-imm :p-apply-end)
 
:builtin-device-size ; (%builtin-device-size devnr)
;; only get lower part of size
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(select-device $builtin-arg1-val)
(%load-typed $tmp1 $io-mem-addr %io-size-l +type-int+ :err-io-error)
(%make-int $apply-result $tmp1)
(jump-imm :p-apply-end)
 
:builtin-device-status ; (%builtin-device-status devnr)
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(select-device $builtin-arg1-val)
(%load-typed $tmp1 $io-mem-addr %io-status +type-int+ :err-io-error)
(%make-int $apply-result $tmp1)
(jump-imm :p-apply-end)
 
 
 
:builtin-error ; (%error reason)
(%set-type-imm $builtin-arg1 +type-t+)
(call :fetch-args)
(%error $builtin-arg1)
 
:builtin-add
(call :builtin-binop-fetch-args)
(%add* $apply-result-val $builtin-arg1-val $builtin-arg2-val)
(%branch* $zero :err-overflow O)
(jump-imm :builtin-binop-end)
:builtin-sub
(call :builtin-binop-fetch-args)
(%sub* $apply-result-val $builtin-arg1-val $builtin-arg2-val)
(%branch* $zero :err-overflow O)
(jump-imm :builtin-binop-end)
:builtin-mul
(call :builtin-binop-fetch-args)
(%mul* $apply-result-val $builtin-arg1-val $builtin-arg2-val)
(%branch* $zero :err-overflow O)
(jump-imm :builtin-binop-end)
:builtin-div
(call :builtin-binop-fetch-args)
(%when (%cmp-datum-imm $builtin-arg2-val 0)
(%error-imm %err-division-by-zero))
;; binary search for the answer
(call :div-wrapper)
(jump-imm :builtin-binop-end)
:div-wrapper
(%sub* $div-res $zero $one)
(%cpy $div-sign $one)
(%cmp-datum $builtin-arg1-val $zero)
(%branch* $zero :div-nozero1 (not N))
(%xor $div-sign $one)
(%mul $builtin-arg1-val $div-res)
:div-nozero1
(%cmp-datum $builtin-arg2-val $zero)
(%branch* $zero :div-nozero2 (not N))
(%xor $div-sign $one)
(%mul $builtin-arg2-val $div-res)
:div-nozero2
(%cmp-datum $div-sign $zero)
(branchimm-false :div-nofix)
(%sub $div-sign $one)
:div-nofix
(call :div-noneg)
:div-afterdiv
(%mul $div-low $div-sign)
(%cpy $apply-result-val $div-low)
:div-slutten
(ret)
 
;; binaersoek: gitt arg1, arg2:
;; finn ans slik at ans*arg2<=arg1 og (ans+1)*arg2>arg1
 
:div-noneg
(%cmp-datum $builtin-arg1-val $builtin-arg2-val)
(branchimm-false :div-notequal)
(%cpy $div-low $one)
(ret)
:div-notequal
(%cmp-datum $builtin-arg1-val $builtin-arg2-val)
(%branch* $zero :div-fortsett (not N))
(%cpy $div-low $zero)
(ret)
:div-fortsett
(%set-datum $div-low $one)
(%set-type-imm $div-low +type-int+)
(%set-datum-imm $div-high 18631)
(%set-type-imm $div-high +type-int+)
(%set-datum-imm $div-mid 1801)
(%set-type-imm $div-mid +type-int+)
(%mul $div-high $div-mid) ;; voila, 2^25-1 (luckily 25 isn't prime)
 
(%cmp-datum $builtin-arg2-val $zero)
(branchimm-false :div-check1)
(%cpy $div-low $zero)
(jump-imm :div-end)
;; error
:div-check1
(%sub* $div-mid $div-high $div-low)
(%cmp-datum $div-mid $one)
(branchimm :div-end)
 
:div-bsloop
(%sub* $div-mid $div-high $div-low)
(%shift-r $div-mid $one)
(%add $div-mid $div-low)
(%mul* $div-res $div-mid $builtin-arg2-val)
(%branch* $zero :div-toohigh O)
(%sub $div-res $one)
(%cmp-datum $div-res $builtin-arg1-val)
(%branch* $zero :div-toohigh (not N))
(%cpy $div-low $div-mid)
(jump-imm :div-check1)
:div-toohigh
(%cpy $div-high $div-mid)
(jump-imm :div-check1)
:div-end
(ret)
:builtin-mod
(call :builtin-binop-fetch-args)
(%cpy $mod-val1 $builtin-arg1-val)
(%cpy $mod-val2 $builtin-arg2-val)
(%when (%cmp-datum-imm $builtin-arg2-val 0)
(%error-imm %err-division-by-zero))
(call :div-wrapper)
:modbreak
(%mul $apply-result-val $mod-val2)
(%sub $mod-val1 $apply-result-val)
(%cpy $apply-result-val $mod-val1)
(jump-imm :builtin-binop-end)
:builtin-bitwise-and
(call :builtin-binop-fetch-args)
(%and* $apply-result-val $builtin-arg1-val $builtin-arg2-val)
(jump-imm :builtin-binop-end)
:builtin-bitwise-or
(call :builtin-binop-fetch-args)
(%or* $apply-result-val $builtin-arg1-val $builtin-arg2-val)
(jump-imm :builtin-binop-end)
:builtin-bitwise-not
(%set-type-imm $builtin-arg1 +type-int+)
(call :fetch-args)
(%set-type-imm $apply-result-val +type-int+)
(%not $apply-result-val $builtin-arg1-val)
(jump-imm :p-apply-end)
:builtin-bitwise-shift
(%set-type-imm $builtin-arg1 +type-int+)
(%set-type-imm $builtin-arg2 +type-int+)
(call :fetch-args)
(%cpy $apply-result-val $builtin-arg1-val)
(%cmp-datum-imm $builtin-arg2-val 0)
(%branch* $zero :builtin-bitwise-shift-right N)
(%shift-l $apply-result-val $builtin-arg2-val)
(jump-imm :builtin-binop-end)
:builtin-bitwise-shift-right
(%cpy $tmp1 $zero)
(%sub $tmp1 $builtin-arg2-val) ; $tmp1 = -arg2
(%shift-r $apply-result-val $tmp1)
(jump-imm :builtin-binop-end)
 
:builtin-binop-fetch-args ; subroutine
;; (%set-type-imm $builtin-arg1 +type-t+)
;; (%set-type-imm $builtin-arg2 +type-t+)
(%set-type-imm $builtin-arg1 +type-int+) ; assume all binops want INTs as args
(%set-type-imm $builtin-arg2 +type-int+)
(jump-imm :fetch-args) ; tail call
 
:builtin-binop-end
;; TODO check for errors
(%cmp-type-imm $apply-result-val +type-int+)
(branchimm :builtin-binop-end-int)
(alloc-imm 1)
(%store $apply-result-val $alloc-addr 0)
(%set-datum $apply-result $alloc-addr)
(jump-imm :p-apply-end)
:builtin-binop-end-int
(%make-int $apply-result $apply-result-val)
(jump-imm :p-apply-end)
 
:builtin-num-eq? ; (%num-eq? n1 n2)
(call :builtin-binop-fetch-args)
(%set-datum-imm $apply-result %nil)
(%when (%cmp-datum $builtin-arg1-val $builtin-arg2-val)
(%set-datum-imm $apply-result %t))
(jump-imm :p-apply-end)
 
:builtin-less-than? ; (%less-than? n1 n2)
(call :builtin-binop-fetch-args)
(%set-datum-imm $apply-result %t)
(%cmp-datum $builtin-arg1-val $builtin-arg2-val)
(%branch* $zero :builtin-less-than?-end N)
(%set-datum-imm $apply-result %nil)
:builtin-less-than?-end
(jump-imm :p-apply-end)
 
:builtin-current-environment ; (%current-environment)
(call :fetch-args)
(%set-datum $apply-result $f-env)
(jump-imm :p-apply-end)
 
:builtin-make-eval-state ; (%make-eval-state expr env)
(%set-type-imm $builtin-arg1 +type-t+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
;; TODO should we do some typechecking here?
(%set-datum $tmp1 $builtin-arg1)
(%set-datum $tmp2 $builtin-arg2)
(pop-eframe)
(call :push-s)
(call :init-evaluation-level)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval)
(%set-datum $f-env $tmp2)
(call :interrupt)
(jump-imm :main-loop-end) ; note: not :p-apply-end
 
:builtin-eval-partial ; (%eval-partial state iterations) => new-state
(%set-type-imm $builtin-arg1 +type-t+)
(%set-type-imm $builtin-arg2 +type-int+)
(call :fetch-args)
;; TODO should we do some typechecking here?
(%set-datum $tmp1 $builtin-arg1)
(%set-datum $tmp2 $builtin-arg2-val)
(pop-eframe)
(call :push-s)
(%set-datum $s-addr $tmp1)
(call :load-sframe-without-parent)
(%set-datum $s-iterations $tmp2)
(jump-imm :main-loop)
 
:builtin-define ; (%define symb val) => val
(%set-type-imm $builtin-arg1 +type-symbol+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%cons $tmp1 $builtin-arg1 $builtin-arg2) ; $tmp1: new binding
(%car $tmp2 $f-env :err-invalid-env) ; $tmp2: local binding list
(%cons $tmp1 $tmp1 $tmp2) ; $tmp1: new local binding list
(%store-typed $tmp1 $f-env 0 +type-cons+) ; (set-car! $f-env $tmp1)
(%set-datum $apply-result $builtin-arg2)
(jump-imm :p-apply-end)
 
:builtin-undefine ; (%undefine symb) => nil
;;(%set-type-imm $builtin-arg1 +type-symbol+)
;;(call :fetch-args)
;;TODO
(message-str "UNDEF")
(%halt)
 
:builtin-set! ; (%set! symb val) => val
(%set-type-imm $builtin-arg1 +type-symbol+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%set-datum $tmp1 $builtin-arg1)
(%set-datum (e-arg) $builtin-arg2)
(%set-datum-imm (e-phase) %phase-set!)
(push-eframe)
(%set-datum (e-expr) $tmp1)
(%set-datum (e-arg) $f-env)
(%set-datum-imm (e-phase) %phase-env-lookup)
(jump-imm :main-loop-end)
 
:builtin-set-car! ; (%set-car! cell val) => val
(%set-type-imm $builtin-arg1 +type-cons+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%store-typed $builtin-arg2 $builtin-arg1 0 +type-cons+)
(%set-datum $apply-result $builtin-arg2)
(jump-imm :p-apply-end)
 
:builtin-set-cdr! ; (%set-cdr! cell val) => val
(%set-type-imm $builtin-arg1 +type-cons+)
(%set-type-imm $builtin-arg2 +type-t+)
(call :fetch-args)
(%store-typed $builtin-arg2 $builtin-arg1 0 +type-snoc+)
(%set-datum $apply-result $builtin-arg2)
(jump-imm :p-apply-end)
 
:builtin-function-data
(%set-type-imm $builtin-arg1 +type-function+)
(call :fetch-args)
(%load $apply-result $builtin-arg1 0)
(jump-imm :p-apply-end)
 
:builtin-builtin-name
(%set-type-imm $builtin-arg1 +type-builtin+)
(call :fetch-args)
(%load $apply-result $builtin-arg1 0)
(jump-imm :p-apply-end)
 
 
:p-apply-end
(pop-eframe)
(%set-datum (e-result) $apply-result)
(jump-imm :main-loop-end)
 
 
;; subroutine for getting the arguments to a builtin function
:fetch-args
(%set-datum $fetch-args-arglist (e-result))
 
(%set-datum-imm $fetch-args-arg-reg $builtin-arg1)
(%set-datum-imm $fetch-args-argval-reg $builtin-arg1-val)
:fetch-args-loop
 
(%cmp-type-imm (indirect-register $fetch-args-arg-reg) +type-none+)
(branchimm :fetch-args-end)
(%car $fetch-args-arg $fetch-args-arglist :err-too-few-args)
(%load $fetch-args-argval $fetch-args-arg 0)
(%when-not (%cmp-type-imm (indirect-register $fetch-args-arg-reg) +type-t+)
(%when-not (%cmp-type (indirect-register $fetch-args-arg-reg) $fetch-args-argval)
(%error-imm %err-type-error)))
(%cpy (indirect-register $fetch-args-arg-reg) $fetch-args-arg)
(%cpy (indirect-register $fetch-args-argval-reg) $fetch-args-argval)
(%cdr $fetch-args-arglist $fetch-args-arglist :err-too-few-args)
 
(%cmp-datum-imm $fetch-args-arg-reg $builtin-arg3)
(branchimm :fetch-args-end)
(%add $fetch-args-arg-reg $one)
(%add $fetch-args-argval-reg $one)
(jump-imm :fetch-args-loop)
 
:fetch-args-end
(%cmp-datum-imm $fetch-args-arglist %nil)
(branchimm-false :err-too-many-args)
(ret)
 
 
 
:p-apply-function1
(%set-datum-imm (e-phase) %phase-apply-function)
(%cdr $tmp1 $apply-func :err-invalid-function) ; $tmp1: (param-list expr env)
(%car $tmp1 $tmp1 :err-invalid-function) ; $tmp1: param list
(%set-datum $tmp2 (e-result)) ; $tmp2: arg list
(push-eframe)
(%set-datum-imm (e-expr) %nil)
(%set-datum (e-arg) $tmp1)
(%set-datum (e-result) $tmp2)
(%set-datum-imm (e-phase) %phase-bind-args)
(jump-imm :main-loop-end)
 
;; PHASE: APPLY-FUNCTION
 
:p-apply-function2
;; (e-arg): function (address)
;; (e-result): list of argument bindings (address)
(%load-typed $apply-func (e-arg) 0 +type-function+ :err-not-a-function)
(%cdr $cdr $apply-func :err-invalid-function) ; $cdr: (param-list expr env)
(%cdr $cdr $cdr :err-invalid-function) ; $cdr: (expr env)
(%car $tmp1 $cdr :err-invalid-function) ; $tmp1: expr
(%cdr $cdr $cdr :err-invalid-function) ; $cdr: (env)
(%car $tmp2 $cdr :err-invalid-function) ; $tmp2: env
(%cons $tmp2 (e-result) $tmp2) ; $tmp2: new env
(%set-datum $tmp3 (e-arg)) ; $tmp3: function (address)
(call :push-or-reuse-fframe)
(%set-datum $f-func $tmp3)
(%set-datum $f-env $tmp2)
(%set-datum (e-expr) $tmp1)
(%set-datum-imm (e-phase) %phase-eval)
(jump-imm :main-loop-end)
 
 
;; PHASE: SET!
 
:p-set!
;; (e-arg): new value
;; (e-result): existing binding (or nil if variable is unbound)
(%cmp-datum-imm (e-result) %nil)
(branchimm :err-unbound-symbol)
(%car $tmp1 (e-result) :err-invalid-state) ; check that (e-result) is a cons cell
(%store-typed (e-arg) (e-result) 1 +type-snoc+) ; (set-cdr! (e-result) (e-arg))
(%set-datum $tmp1 (e-arg))
(pop-eframe)
(%set-datum (e-result) $tmp1)
(jump-imm :main-loop-end)
 
 
;; PHASE: INITIAL
 
:p-initial
(%when (%cmp-datum-imm $s-parent %nil)
(message-str "HALT")
(%halt))
(call :interrupt)
;; (jump-imm :main-loop-end) ; not necessary here
 
 
;; All paths inside the main loop lead to here
:main-loop-end
(%cmp-datum $gc-firstfree $gc-mem-limit) ; lots of memory left?
(%branch* $zero :main-loop-end-after-gc N) ; if so, skip GC
;; Not enough memory, invoke GC. First store the evaluation state:
(call :store-sframe)
(%set-type-imm $tmp1 +type-cons+)
(%set-datum $tmp1 $s-addr)
(%store $tmp1 $zero %memory-root)
;; Then call garbage collector:
(call :gc-garbagecollect)
(%cmp-datum $gc-firstfree $gc-mem-limit) ; lots of memory now?
(%branch* $zero :out-of-memory (not N)) ; if not, give up completely
(%load $s-addr $zero %memory-root)
(call :load-sframe)
:main-loop-end-after-gc
(%cmp-datum-imm $s-iterations 0)
(branchimm :main-loop)
(%sub $s-iterations $one)
(%cmp-datum-imm $s-iterations 0)
(branchimm-false :main-loop)
(%set-datum-imm $s-condition %timeout)
(call :interrupt)
(jump-imm :main-loop)
 
 
:out-of-memory
(message-str "ERROR: OUT OF MEMORY")
(%halt)
 
 
;; ERROR HANDLERS:
 
:err-not-a-list
(%error-imm %err-not-a-list)
 
:err-not-a-pair
(%error-imm %err-not-a-pair)
 
:err-not-a-function
(%error-imm %err-not-a-function)
 
:err-malformed-form
(%error-imm %err-malformed-form)
 
:err-invalid-function
(%error-imm %err-invalid-function)
 
:err-invalid-builtin
(%error-imm %err-invalid-builtin)
 
:err-invalid-env
(%error-imm %err-invalid-env)
 
:err-unbound-symbol
(%error-imm %err-unbound-symbol)
 
:err-invalid-param-list
(%error-imm %err-invalid-param-list)
:err-too-few-args
(%error-imm %err-too-few-args)
:err-too-many-args
(%error-imm %err-too-many-args)
 
:err-invalid-array-index
(%error-imm %err-invalid-array-index)
 
:err-invalid-phase
(%error-imm %err-invalid-phase)
 
:err-invalid-state
(%error-imm %err-invalid-state)
 
:err-io-error
(%error-imm %err-io-error)
 
:err-overflow
(%error-imm %err-overflow)
 
 
;; SUBROUTINES:
 
:make-empty-environment
(%set-datum-imm $env %nil)
(%cons $env $env $env)
(ret)
 
 
;; Subroutine. Initializes a new evaluation level (that is, a new
;; state). Puts an initial e-frame at the bottom of the e/f
;; buffer, pushes an e-frame on top of it (it is the caller's
;; responsibility to initialize expr and phase in this new frame).
:init-evaluation-level
(%set-datum-imm $s-condition %nil)
(%set-datum-imm $s-iterations 0)
 
(%set-datum-imm $f-func %nil)
(call :make-empty-environment)
(%set-datum $f-env $env)
(%set-datum-imm $f-addr %nil)
 
(%set-datum-imm $e-expr $e/f-min-expr)
(%set-datum-imm $e-arg $e/f-min-arg)
(%set-datum-imm $e-result $e/f-min-result)
(%set-datum-imm $e-phase $e/f-min-phase)
 
(%set-type-imm (e-expr) +type-cons+)
(%set-datum-imm (e-expr) %nil)
(%set-datum-imm (e-arg) %nil)
(%set-datum-imm (e-result) %nil)
(%set-datum-imm (e-phase) %phase-initial)
(%set-datum-imm $e-addr %nil)
(push-eframe)
(ret)
 
 
;; Subroutine. End the current evaluation level. Stores the whole
;; state to memory, returns it to the active e-frame in the
;; previous level (or halt the machine if we were at the
;; top-level).
:interrupt
(%cmp-datum-imm $s-parent %nil)
(branchimm :interrupt-at-top-level)
(call :store-sframe-without-parent)
(%set-datum $interrupt-tmp $s-addr)
(call :pop-s)
(%set-datum (e-result) $interrupt-tmp)
(ret)
:interrupt-at-top-level
(message-str "ERR:INTERRUPT")
(%load $tmp1 $s-condition 1)
(message-reg $tmp1)
(message-reg $e-expr)
(message-reg $e-arg)
(message-reg $e-result)
(message-reg $e-phase)
(%halt)
 
 
;; STACK SUBROUTINES
 
;; Subroutine to take care of the cases in pushing e-frames when the
;; new place isn't immediately available. This might be either because
;; it is above the top of the buffer (in which case we should wrap
;; around) or because it is occupied (in which case we should store
;; the frame which is there to main memory).
:push-eframe-handle-overflow
(%cmp-datum-imm $e-expr $e/f-above-marker)
(branchimm-false :push-eframe-handle-overflow-store)
(%set-datum-imm $e-expr $e/f-min-expr)
(%set-datum-imm $e-arg $e/f-min-arg)
(%set-datum-imm $e-result $e/f-min-result)
(%set-datum-imm $e-phase $e/f-min-phase)
(%cmp-type-imm (e-expr) +type-none+)
(branchimm :push-eframe-handle-overflow-end)
:push-eframe-handle-overflow-store
;; buffer is full
(%cmp-type-imm (e-expr) +type-function+)
(branchimm-false :push-eframe-handle-overflow-store-e)
(call :store-fframe) ; sets $f-addr
(jump-imm :push-eframe-handle-overflow-end)
:push-eframe-handle-overflow-store-e
(call :store-eframe) ; sets $e-addr
:push-eframe-handle-overflow-end
(%set-datum-imm (e-expr) +type-cons+)
(ret)
 
 
:pop-eframe-handle-underflow
(%cmp-datum-imm $e-expr $e/f-below-marker)
(branchimm-false :pop-eframe-handle-underflow-load)
(%set-datum-imm $e-expr $e/f-max-expr)
(%set-datum-imm $e-arg $e/f-max-arg)
(%set-datum-imm $e-result $e/f-max-result)
(%set-datum-imm $e-phase $e/f-max-phase)
(%cmp-type-imm (e-expr) +type-none+)
(branchimm-false :pop-eframe-handle-underflow-end)
:pop-eframe-handle-underflow-load
;; buffer is empty
(%cmp-datum-imm $e-addr %nil)
(branchimm-false :pop-eframe-handle-underflow-load-e)
(jump-imm :load-fframe) ; tail call
;; (call :load-f-and-e-frame-to-empty-buffer) ; sets $e-addr, $f-addr
;; (ret)
:pop-eframe-handle-underflow-load-e
(call :load-eframe)
:pop-eframe-handle-underflow-end
(ret)
 
 
 
 
:store-eframe
(%set-type-imm (indirect-register $e-expr) +type-cons+)
(%set-type-imm (indirect-register $e-arg) +type-cons+)
(%set-type-imm (indirect-register $e-result) +type-cons+)
(%set-type-imm (indirect-register $e-phase) +type-cons+)
(%set-type-imm $e-addr +type-cons+)
(alloc-imm 10)
(%set-type-imm $e-tmp1 +type-snoc+)
(%set-datum $e-tmp1 $alloc-addr)
(%set-type-imm $e-tmp2 +type-int+)
(%set-datum-imm $e-tmp2 2)
(%set-type-imm $e-tmp3 +type-int+)
(%set-datum $e-tmp3 $e-tmp1)
(%store $e-addr $e-tmp1 0)
(%store $list-terminator $e-tmp1 1)
(%store (indirect-register $e-phase) $e-tmp1 2)
(%store $e-tmp1 $e-tmp1 3)
(%add $e-tmp3 $e-tmp2)
(%set-datum $e-tmp1 $e-tmp3)
(%store (indirect-register $e-result) $e-tmp1 2)
(%store $e-tmp1 $e-tmp1 3)
(%add $e-tmp3 $e-tmp2)
(%set-datum $e-tmp1 $e-tmp3)
(%store (indirect-register $e-arg) $e-tmp1 2)
(%store $e-tmp1 $e-tmp1 3)
(%add $e-tmp3 $e-tmp2)
(%set-datum $e-tmp1 $e-tmp3)
(%store (indirect-register $e-expr) $e-tmp1 2)
(%store $e-tmp1 $e-tmp1 3)
(%add $e-tmp3 $e-tmp2)
(%set-datum $e-addr $e-tmp3)
(ret)
 
:load-eframe
(%car (indirect-register $e-expr) $e-addr :load-eframe-error)
(%cdr $e-tmp1 $e-addr :load-eframe-error)
(%car (indirect-register $e-arg) $e-tmp1 :load-eframe-error)
(%cdr $e-tmp1 $e-tmp1 :load-eframe-error)
(%car (indirect-register $e-result) $e-tmp1 :load-eframe-error)
(%cdr $e-tmp1 $e-tmp1 :load-eframe-error)
(%car (indirect-register $e-phase) $e-tmp1 :load-eframe-error)
(%cdr $e-tmp1 $e-tmp1 :load-eframe-error)
(%car $e-addr $e-tmp1 :load-eframe-error)
(ret)
:load-eframe-error
(message-str "ERR:L-E")
(%halt)
 
 
 
;; Subroutine. Makes sure there is a function frame with a single
;; evaluation frame at the top of the stack. These might be the
;; frames currently at the top (if the current e-frame has no
;; parent, in which case it is safe to tail-call optimize) or new
;; frames. If a new f-frame is pushed, the current e-frame is
;; popped first.
:push-or-reuse-fframe
(%sub* $f-tmp1 $e-expr $e/f-frame-size)
(%when (%cmp-datum-imm $f-tmp1 $e/f-below-marker)
(%set-datum-imm $f-tmp1 $e/f-max-expr))
;; is frame below current a func frame?
(%cmp-type-imm (indirect-register $f-tmp1) +type-function+)
;; if it is, eframe has no parent, so we can reuse fframe:
(branchimm :push-or-reuse-fframe-can-reuse)
;; is frame below current empty?
(%cmp-type-imm (indirect-register $f-tmp1) +type-none+)
;; if not, eframe has parent in e/f buffer, so we cannot reuse fframe:
(branchimm-false :push-or-reuse-fframe-cannot-reuse)
;; if we got here, $e-addr is the address of this e-frame's
;; parent. check if it is NIL:
(%cmp-datum-imm $e-addr %nil)
;; if not, eframe has parent in memory, so cannot reuse fframe:
(branchimm-false :push-or-reuse-fframe-cannot-reuse)
:push-or-reuse-fframe-can-reuse
;; if we get to here, the eframe has no parent, so we can reuse fframe:
(%set-datum-imm (indirect-register $e-arg) %nil)
(%set-datum-imm (indirect-register $e-result) %nil) ; caller must set $e-expr, $e-phase
(ret)
:push-or-reuse-fframe-cannot-reuse
(pop-eframe)
(call :push-fframe)
(push-eframe)
(ret)
 
 
;; Subroutine. Pushes the current f-frame onto the e/f buffer.
:push-fframe
;; get a nice empty place in the e/f buffer:
(push-eframe)
;; put our current fframe there:
(%set-datum (indirect-register $e-expr) $f-func)
(%set-datum (indirect-register $e-arg) $f-env)
;; mark this as being an fframe by setting the type of the first
;; register:
(%set-type-imm (indirect-register $e-expr) +type-function+)
(ret)
 
 
 
;; Subroutine. Stores the current frame in e/f buffer as an
;; f-frame. Sets $f-addr to the address it was stored to, $e-addr to
;; %nil (to indicate that the e-frame directly above this in the
;; buffer has no parent).
:store-fframe
(%set-type-imm (indirect-register $e-expr) +type-cons+)
(%set-type-imm (indirect-register $e-arg) +type-cons+)
(%set-type-imm $f-addr +type-cons+)
(alloc-imm 8)
(%set-type-imm $f-tmp1 +type-snoc+)
(%set-datum $f-tmp1 $alloc-addr)
(%set-type-imm $f-tmp2 +type-int+)
(%set-datum-imm $f-tmp2 2)
(%set-type-imm $f-tmp3 +type-int+)
(%set-datum $f-tmp3 $f-tmp1)
(%store $f-addr $f-tmp1 0)
(%store $list-terminator $f-tmp1 1)
(%store $e-addr $f-tmp1 2)
(%store $f-tmp1 $f-tmp1 3)
(%add $f-tmp3 $f-tmp2)
(%set-datum $f-tmp1 $f-tmp3)
(%store (indirect-register $e-arg) $f-tmp1 2)
(%store $f-tmp1 $f-tmp1 3)
(%add $f-tmp3 $f-tmp2)
(%set-datum $f-tmp1 $f-tmp3)
(%store (indirect-register $e-expr) $f-tmp1 2)
(%store $f-tmp1 $f-tmp1 3)
(%add $f-tmp3 $f-tmp2)
(%set-datum $f-addr $f-tmp3)
(%set-datum-imm $e-addr %nil)
(ret)
 
;; Subroutine. Loads an f-frame into the e/f buffer. The f-frame is
;; found at the memory address in $f-addr; this register is changed to
;; be the address of this frame's parent. Sets $e-addr to the address
;; of the top e-frame in this f-frame.
:load-fframe
(%car $f-tmp1 $f-addr :load-fframe-error)
(%set-datum (e-expr) $f-tmp1)
(%set-type-imm (e-expr) +type-function+)
(%cdr $f-tmp1 $f-addr :load-fframe-error)
(%car (e-arg) $f-tmp1 :load-fframe-error)
(%cdr $f-tmp1 $f-tmp1 :load-fframe-error)
(%car $e-addr $f-tmp1 :load-fframe-error)
(%cdr $f-tmp1 $f-tmp1 :load-fframe-error)
(%car $f-addr $f-tmp1 :load-fframe-error)
(ret)
;;(jump-imm :load-eframe) ; tail call
:load-fframe-error
(message-str "ERR:L-F")
(%halt)
 
 
:load-f-and-e-frame-to-empty-buffer
(call :load-fframe)
(%set-datum $f-func (e-expr))
(%set-datum $f-env (e-arg))
(%set-type-imm (e-expr) +type-none+)
(jump-imm :load-eframe) ; tail call
 
 
 
:store-e/f-stack
(call :push-fframe) ; put current fframe into e/f buffer
(%set-datum $e/f-top $e-expr) ; remember current position
;; Traverse the whole buffer, pushing dummy frames. This has the
;; effect that all frames in the buffer will be stored to main memory.
:store-e/f-stack-loop
(push-eframe)
(%set-type-imm (indirect-register $e-expr) +type-none+)
(%cmp-datum $e-expr $e/f-top)
(branchimm-false :store-e/f-stack-loop)
(ret)
 
 
:push-s
(call :store-sframe)
(%set-datum $s-parent $s-addr)
(ret)
 
 
:store-sframe
(%cons $s-tmp $s-parent $list-terminator)
:store-sframe-without-parent-1
(%make-obj $s-iterations $s-iterations +type-int+)
(%cons $s-tmp $s-iterations $s-tmp)
(%cons $s-tmp $s-condition $s-tmp)
(call :store-e/f-stack) ; stores the whole e/f buffer, we get address
; of top f-frame in $f-addr
(%cons $s-tmp $f-addr $s-tmp)
(%set-datum $s-addr $s-tmp)
(ret)
:store-sframe-without-parent
(%set-datum-imm $s-tmp %nil)
(jump-imm :store-sframe-without-parent-1)
 
 
 
:pop-s
(%set-datum $s-addr $s-parent)
:load-sframe
(call :load-sframe-common)
(%cdr $s-tmp $s-tmp :load-sframe-error)
(%car $s-parent $s-tmp :load-sframe-error)
(jump-imm :load-f-and-e-frame-to-empty-buffer) ; tail call
:load-sframe-error
;;(%error %err-invalid-state)
(message-str "ERR:L-S")
(%halt)
 
 
 
:load-sframe-without-parent
(call :load-sframe-common)
(jump-imm :load-f-and-e-frame-to-empty-buffer) ; tail call
:load-sframe-without-parent-error
(%halt)
 
:load-sframe-common
(%car $f-addr $s-addr :load-sframe-error)
(%cdr $s-tmp $s-addr :load-sframe-error)
(%car $s-condition $s-tmp :load-sframe-error)
(%cdr $s-tmp $s-tmp :load-sframe-error)
(%car $s-iterations $s-tmp :load-sframe-error)
(%load $s-iterations $s-iterations 0)
(ret)
 
 
 
;; OUTPUT
 
;; Subroutine, print int from $message
:message-reg
(select-device-imm +dev-serial+)
(%set-datum-imm $message-shift 24)
(%set-datum-imm $message-mask #xF)
:message-reg-loop
(%set-datum $message-tmp1 $message)
(%shift-r $message-tmp1 $message-shift)
(%and $message-tmp1 $message-mask)
(%set-datum-imm $message-tmp2 (char-int #\0))
(%cmp-datum-imm $message-tmp1 #xA)
(%branch* $zero :message-reg-below-a N)
(%set-datum-imm $message-tmp2 (- (char-int #\A) #xA))
:message-reg-below-a
(%add $message-tmp1 $message-tmp2)
(%store $message-tmp1 $io-mem-addr %io-object)
(%cmp-datum-imm $message-shift 0)
(branchimm :message-reg-loop-end)
(%set-datum-imm $message-tmp1 4)
(%sub $message-shift $message-tmp1)
(jump-imm :message-reg-loop)
:message-reg-loop-end
(ret)
 
 
 
 
;; GARBAGE COLLECTOR
 
 
;; Garbage collection subroutine
:gc-garbagecollect
(message-str-no-nl ":")
 
;; mark everything as free
(%cpy $gc-vi $gc-startofmem)
 
:gc-loop1
;; load the contents of memory address (contained in gc-vi)
;; into register gc-1)
;; loop tested in emu: OK
(%load $gc-1 $gc-vi 0)
;; if gc-flag already free, stop
(%cmp-gc-imm $gc-1 +gc-free+)
(branchimm :gc-nodeletegc)
(%set-gc-imm $gc-1 +gc-free+)
(%store $gc-1 $gc-vi 0)
:gc-nodeletegc
(%add $gc-vi $one)
(%cmp-datum $gc-vi $gc-gcspace)
(branchimm-false :gc-loop1)
;; pointer reversal! skrekk og gru
;; algorithm based on tiger book
 
;; start of pointer reversal
;; the algorithm is able to "slide" sideways without reversing
;; underlying pointers within the following structures
;; CONS - SNOC
;; ARRAY - PTR - ... - PTR - SNOC
 
;; CONS/ARRAY are identified as start of structure
;; SNOC is identified as end of structure
 
(%set-type-imm $gc-t +type-int+)
(%set-datum-imm $gc-t 0)
(%cpy $gc-x $gc-rootptr)
 
 
:gc-mainreverseloop
 
;; visit current block
;; gc-x holds current memory address
;; gc-y will hold the contents of the address
(%load $gc-y $gc-x 0)
(%set-gc-imm $gc-y +gc-used+)
(%store $gc-y $gc-x 0)
 
(%cpy $gc-followp $zero)
(%cpy $gc-cannext $zero)
(%cpy $gc-canprev $zero)
 
;; if memory address x contains a pointer, and it points to
;; a memory address marked as gc-free (ie. unvisited so far)
;; set followp to true (1)
;; the following types have pointers: CONS PTR SNOC
;; tested OK for case: cell is pointer, cell pointed to is unvisited
(%cmp-type-imm $gc-y +type-cons+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-snoc+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-ptr+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-function+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-symbol+)
(branchimm :gc-setfollowp)
(%cmp-type-imm $gc-y +type-builtin+)
(branchimm :gc-setfollowp)
;; if any other types contain pointers, add them here!
(jump-imm :gc-afterfollowp)
 
:gc-setfollowp
 
;; don't follow pointer if it's a low address
; (%cmp-datum $gc-y $gc-startofmem)
; (%branch* $zero :gc-afterfollowp (not N))
 
; copy from memory location $gc-y, into $gc-v
(%load $gc-v $gc-y 0)
(%cmp-gc-imm $gc-v +gc-used+)
(branchimm :gc-afterfollowp)
(%cpy $gc-followp $one)
 
:gc-afterfollowp
 
;; if we aren't at the last position of a memory structure spanning
;; several addresses and the next adress is free, set cannext=1
;; currently, these types can occur at the non-end: CONS, ARRAY, PTR
;; tested OK for case: cell is not end of structure, next cell is unvisited
(%cmp-type-imm $gc-y +type-cons+)
(branchimm :gc-setcannext)
(%cmp-type-imm $gc-y +type-array+)
(branchimm :gc-setcannext)
(%cmp-type-imm $gc-y +type-ptr+)
(branchimm :gc-setcannext)
(jump-imm :gc-aftercannext)
:gc-setcannext
(%cpy $gc-1 $gc-x) ;; check is address x+1 is unvisited
(%add $gc-1 $one)
(%load $gc-1 $gc-1 0) ;; lykkebo says this is safe
(%cmp-gc-imm $gc-1 +gc-used+)
(branchimm :gc-aftercannext)
(%cpy $gc-cannext $one)
 
:gc-aftercannext
 
;; if we aren't at the first position of a memory structure spanning
;; several addresses, set canprev=1
;; the following types can occur at the non-start: SNOC PTR
;; tested OK for case: cell is not end of structure
(%cmp-type-imm $gc-y +type-snoc+)
(branchimm :gc-setcanprev)
(%cmp-type-imm $gc-y +type-ptr+)
(branchimm :gc-setcanprev)
(jump-imm :gc-aftercanprev)
:gc-setcanprev
(%cpy $gc-canprev $one)
 
:gc-aftercanprev
 
;; do stuff based on followp, cannext, canprev
;; follow the pointer we're at, and reverse the pointer
(%cmp-datum $gc-followp $one)
(branchimm-false :gc-afterfollowedp)
(%cpy $gc-temp $gc-x)
(%load $gc-mem $gc-temp 0)
(%set-datum $gc-mem $gc-t)
(%store $gc-mem $gc-temp 0)
(%cpy $gc-t $gc-temp)
(%set-datum $gc-x $gc-y)
(jump-imm :gc-mainreverseloop)
 
:gc-afterfollowedp
 
;; move to next memory location
(%cmp-datum $gc-cannext $one)
(branchimm-false :gc-aftercouldnext)
(%add $gc-x $one)
(jump-imm :gc-mainreverseloop)
 
:gc-aftercouldnext
 
;; move to previous memory location
(%cmp-datum $gc-canprev $one)
(branchimm-false :gc-aftercouldprev)
;; address 0x48
(%sub $gc-x $one)
(jump-imm :gc-mainreverseloop)
 
:gc-aftercouldprev
 
;; all cases exhausted: follow pointer back and reverse the reversal
(%cmp-datum $gc-t $zero)
(branchimm :gc-donepointerreversal)
(%load $gc-temp $gc-t 0) ;; read from address gc-t, into gc-temp
(%cpy $gc-mem $gc-temp)
(%set-datum $gc-mem $gc-x)
(%store $gc-mem $gc-t 0) ;; restore the correct pointer in gc-t
(%cpy $gc-x $gc-t)
(%cpy $gc-t $gc-temp)
(jump-imm :gc-mainreverseloop)
 
:gc-donepointerreversal
 
 
(message-str-no-nl ",")
 
;; end of pointer reversal routine, from this point on,
;; all variables marked with "ptr-rev" are free for other use
 
;; pre-fill low memory values into translation area
(%cpy $gc-from $zero)
(%cpy $gc-to $gc-gcspace)
:gc-prefill
(%store $gc-from $gc-to 0)
(%add $gc-from $one)
(%add $gc-to $one)
(%cmp-datum $gc-from $gc-startofmem)
(branchimm-false :gc-prefill)
 
;; copy the stuff
 
(%cpy $gc-to $gc-from)
(%cpy $gc-baseaddr $zero)
:gc-copyloop
 
(%load $gc-mem $gc-from 0) ;; read from gc-from into gc-mem
(%cmp-gc-imm $gc-mem +gc-used+)
(branchimm-false :gc-notrans)
;; put address in translation table
(%cpy $gc-temp $gc-from)
(%sub $gc-temp $gc-baseaddr)
; (%div* $gc-mem $gc-from $gc-spacesize)
; (%mul $gc-mem $gc-spacesize)
; (%cpy $gc-temp2 $gc-from)
; (%sub $gc-temp2 $gc-mem)
(%add $gc-temp $gc-gcspace)
(%store $gc-to $gc-temp 0) ;; write to-address to gc-temp
;; copy
;; (%load $gc-mem $gc-from 0)
(%store $gc-mem $gc-to 0)
(%add $gc-to $one)
:gc-notrans
(%add $gc-from $one)
 
(%cpy $gc-temp $gc-baseaddr)
(%add $gc-temp $gc-spacesize)
 
; (%div* $gc-temp $gc-from $gc-spacesize)
; (%mul $gc-temp $gc-spacesize)
; (%sub* $gc-temp2 $gc-from $gc-temp)
(%cmp-datum $gc-from $gc-temp)
(branchimm-false :gc-noconvert)
 
;; translate pointers
:gc-transloop
(%cpy $gc-vi $gc-startofmem)
 
(message-str-no-nl ".")
 
:gc-transloop2
(%load $gc-mem $gc-vi 0) ;; read from address gc-i and put into gc-mem
(%cmp-gc-imm $gc-mem +gc-used+)
(branchimm-false :gc-nexttrans)
(%cmp-type-imm $gc-mem +type-ptr+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-cons+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-snoc+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-symbol+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-function+)
(branchimm :gc-isptr)
(%cmp-type-imm $gc-mem +type-builtin+)
(branchimm :gc-isptr)
(jump-imm :gc-nexttrans)
 
:gc-isptr
;; check that these branches work
;; OK for mem>=from-spacesize og mem<from
(%sub* $gc-temp $gc-from $gc-spacesize)
(%cmp-datum $gc-mem $gc-temp)
(%branch* $zero :gc-nexttrans N)
(%cmp-datum $gc-mem $gc-from)
(%branch* $zero :gc-nexttrans (not N))
 
;; calculate gcspace+val%spacesize, put in val
(%cpy $gc-val $gc-mem)
(%sub $gc-val $gc-baseaddr)
(%add $gc-val $gc-gcspace)
 
; (%div* $gc-temp $gc-val $gc-spacesize)
; (%mul $gc-temp $gc-spacesize)
; (%sub* $gc-temp2 $gc-val $gc-temp)
; (%add* $gc-val $gc-temp2 $gc-gcspace)
(%load $gc-temp2 $gc-val 0)
(%set-datum $gc-mem $gc-temp2)
(%store $gc-mem $gc-vi 0)
 
:gc-nexttrans
(%add $gc-vi $one)
(%cmp-datum $gc-vi $gc-to)
(branchimm-false :gc-noto)
(%cpy $gc-vi $gc-from)
:gc-noto
(%cmp-datum $gc-vi $gc-gcspace)
(branchimm-false :gc-transloop2)
 
;; done with one block, increase base address
(%add $gc-baseaddr $gc-spacesize)
 
:gc-noconvert
 
(%cmp-datum $gc-from $gc-gcspace)
(branchimm-false :gc-copyloop)
 
;; whee, gc is finished and we have a new address where
;; free space starts
(%cpy $gc-firstfree $gc-to)
(message-str-no-nl ":")
(ret)
;; End of garbage collection subroutine
 
 
:call-error
(message-str "ERR:CALL")
(%halt)
:ret-error
(message-str "ERR:RET")
(%halt)
))
 
 
(defun write-register-file ()
(with-open-file (s
"/tmp/regfile"
:element-type 'character
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(let ((symbols-start #x100))
(format s "size ~X~%" +n-regs+)
;; initialize some general registers:
(format s "addr 0~%")
(format s "int 0~%") ; $zero
(format s "int 1~%") ; $one
(format s "int 2~%") ; $two
(format s "addr ~X~%" $list-terminator)
(format s "snoc ~X~%" %nil)
(format s "addr ~X~%" $mc-stack-top)
(format s "int ~X~%" $mc-stack-min)
(format s "addr ~X~%" $io-mem-addr)
(format s "int 3FFFF00~%")
(format s "addr ~X~%" $gc-maxblocks)
(format s "int ~X~%" +memory-size+)
(format s "addr ~X~%" $gc-spacesize)
(format s "int ~X~%" (floor (/ +memory-size+ +gc-spaces+)))
;; write symbol strings in compressed form (three characters per
;; register):
(format s "addr ~X~%" symbols-start)
(loop for v in (compress-symbols (make-symbols))
do (format s "int ~X~%" v))
;; initialize registers used by initialization:
(format s "addr ~X~%" $init1)
(format s "nil~%") ; init1
(format s "t~%") ; init2
(format s "none~%") ; init3
(format s "int ~X~%" symbols-start) ; init-counter
(format s "int 0~%") ; init-counter2
(format s "int 10~%") ; init-shift1
(format s "int 8~%") ; init-shift2
(format s "int FF~%") ; init-char-mask
(format s "int ~X~%" %area-chars) ; init-chars-start
(format s "int 2~%") ; init-symbol-addr
(format s "int ~X~%" %area-strings) ; init-symbol-str-addr
(format s "int ~X~%" %area-strings) ; init-symbol-char-addr
(format s "array 0~%") ; init-symbol-array
)))
 
(defun make-symbols ()
(let ((symbols "%IF
%QUOTE
%LAMBDA
%PROGN
%CONS
%CAR
%CDR
%EVAL
%APPLY
%TYPE
%MAKE-ARRAY
%ARRAY-SIZE
%ARRAY-GET
%ARRAY-SET
%MAKE-SYMBOL
%SYMBOL-TO-STRING
%CHAR-TO-INT
%INT-TO-CHAR
%GET-CHAR
%PUT-CHAR
%NUM-DEVICES
%DEVICE-TYPE
%SET-ADDRESS
%GET-ADDRESS
%ERROR
%ADD
%SUB
%MUL
%DIV
%BITWISE-AND
%BITWISE-OR
%BITWISE-NOT
%BITWISE-SHIFT
%CURRENT-ENVIRONMENT
%MAKE-EVAL-STATE
%EVAL-PARTIAL
%DEFINE
%UNDEFINE
%EQ?
%NUM-EQ?
%CHAR-EQ?
%LESS-THAN?
%MOD
%SET!
%SET-CAR!
%SET-CDR!
%FUNCTION-DATA
%BUILTIN-NAME
%DEVICE-SIZE
%DEVICE-STATUS
 
 
 
 
 
 
 
 
 
 
 
%SYMBOL-TABLE
%PHASE-EVAL
%PHASE-EVAL-ARGS
%PHASE-APPLY
%PHASE-EVAL-IF
%PHASE-INITIAL
%PHASE-ENV-LOOKUP
%PHASE-ENV-LOOKUP-LOCAL
%PHASE-APPLY-FUNCTION
%PHASE-BIND-ARGS
%PHASE-EVAL-PROGN
%PHASE-EVAL-ARGS-TOP
%PHASE-EVAL-ARGS-CDR
%PHASE-EVAL-ARGS-CONS
%PHASE-EVAL-SYMBOL
%PHASE-SET!
 
%TIMEOUT
%ERR-INVALID-PHASE
%ERR-UNBOUND-SYMBOL
%ERR-INVALID-PARAM-LIST
%ERR-TOO-FEW-ARGS
%ERR-TOO-MANY-ARGS
%ERR-INVALID-STATE
%ERR-INVALID-ARG-LIST
%ERR-TYPE-ERROR
%ERR-NOT-A-LIST
%ERR-NOT-A-FUNCTION
%ERR-INVALID-FUNCTION
%ERR-MALFORMED-FORM
%ERR-INVALID-BUILTIN
%ERR-INVALID-ARRAY-INDEX
%ERR-INVALID-ENV
%ERR-NOT-A-PAIR
%ERR-IO-ERROR
%ERR-DIVISION-BY-ZERO
%ERR-OVERFLOW
"))
(loop for ch across symbols
collect (if (char= ch #\Newline)
0
(char-int ch)))))
 
(defun compress-symbols (char-list)
(if char-list
(let* ((c1 (car char-list))
(l1 (cdr char-list))
(c2 (if l1 (car l1) 0))
(l2 (if l1 (cdr l1) nil))
(c3 (if l2 (car l2) 0))
(l3 (if l2 (cdr l2) nil)))
(cons (logior (ash c1 16)
(ash c2 8)
c3)
(compress-symbols l3)))
nil))
/microprogram_assembler/rewrite.lisp
0,0 → 1,35
;;;
;;; with-assembly rewrite routines
;;;
 
(in-package #:mcasm)
 
;; Check if argument is a label
(defun labelp (a)
(typep a 'keyword))
 
;; Add a label to the assembly data
(defun make-label (label)
(when (eq *assembler-state* :gather)
(setf (gethash label *assembler-labels*) *assembler-position*)))
 
; Do instruction rewrite
(defun rewrite-instruction-inst (inst state)
(loop for arg in (cdr inst)
for i from 1
when (eq (argument-to-type arg) 'label)
do (setf (nth i inst)
(if (eq state :gather)
0
`(if (gethash ,arg *assembler-labels*)
(gethash ,arg *assembler-labels*)
(error "Unknown label: ~A" ,arg)))))
inst)
 
;; Rewrite an assembly instruction
;; :label => (make-label :label)
(defun rewrite-instruction (inst state)
(typecase inst
(list (rewrite-instruction-inst inst state))
(keyword `(make-label ,inst))
(t (error "Unknown instruction type: ~A" (type-of inst)))))
/microprogram_assembler/sexptomem.lisp
0,0 → 1,264
;;;
;;; Sexp to memory file
;;;
 
(defpackage #:sexptomem
(:use #:cl))
 
(in-package #:sexptomem)
 
(defvar *symbolinfo*)
(defvar *symbolinfopos*)
(defvar *datastartpos* #x1000)
(defvar *symbolstartpos* (+ *datastartpos* 2))
 
(defun listify (list)
(if (listp list)
list
(list list)))
 
(defun handle-integer (x)
(values nil
(format nil "int ~X" x)
1))
 
(defvar *character-start-position* #x200)
(defun char-position (char)
(+ *character-start-position* (char-code char)))
 
(defun handle-string (str)
(let ((len (length str)))
(values
nil
(concatenate 'list
(list (format nil "array ~X" len))
(loop for ch across str
collect (format nil "ptr ~X" (char-position ch)))
(list "snoc 0"))
(+ 2 len))))
 
(defun handle-special-list (op cons)
t)
 
(defun handle-cons (cons)
(if (eq cons nil)
(values t 0 0)
(if (eq (type-of (car cons)) 'keyword)
(handle-special-list (car cons) (cdr cons))
(handle-list cons))))
 
(defun handle-list (cons)
(if (not cons)
(values t 0 0)
(multiple-value-bind (carinplace cars carp)
(sexp-to-memory-fun (car cons))
(multiple-value-bind (cdrinplace cdrs cdrp)
(handle-list (cdr cons))
(let ((list (concatenate 'list
(list
(if carinplace
(format nil "cons ~X" cars)
(format nil "cons +~X" 2)))
(list (if (not (cdr cons))
(format nil "snoc 0")
(if cdrinplace
(format nil "snoc ~X" cdrs)
(format nil "snoc +~X" (1+ (if carinplace 0 carp))))))
(listify (if carinplace () cars))
(listify (if cdrinplace () cdrs)))))
(values nil list
(+ 2 (if carinplace 0 carp) (if cdrinplace 0 cdrp))))))))
 
(defun handle-symbol (sym)
(let ((res (assoc sym *symbolinfo*)))
(if (not res)
(progn
(setf *symbolinfo* (append *symbolinfo* (list (cons sym *symbolinfopos*))))
(incf *symbolinfopos*)
(handle-symbol sym))
(values t (cdr res) 0))))
 
(defun handle-character (char)
; (values nil (format nil "char ~X ~A" (char-code char) char) 1))
(values t (char-position char) 0))
 
(defun sexp-to-memory-fun (body)
(typecase body
(list (handle-cons body))
(string (handle-string body))
(integer (handle-integer body))
(symbol (handle-symbol body))
(character (handle-character body))
(t (error "Unknown type: ~A~%" (type-of body)))))
 
(defun rewrite-sexp-expr-list-to-cons (list)
(if list
`(%cons ,(rewrite-sexp-expr (car list))
,(rewrite-sexp-expr-list-to-cons (cdr list)))
'%nil))
 
(defun rewrite-sexp-expr-list (list)
(cond ((eq (car list) '%%list)
(rewrite-sexp-expr-list-to-cons (cdr list)))
((eq (car list) 'quote)
(cons '%quote (cdr list)))
((eq (car list) 'let)
`((%lambda anonymous (,(caaadr list))
(%progn
,@(mapcar #'rewrite-sexp-expr (cddr list))))
,(rewrite-sexp-expr (cadr (caadr list)))))
((eq (car list) 'defun)
(when (< (length list) 4)
(error "Malformed DEFUN ~A" list))
(let ((name (cadr list))
(params (caddr list))
(body (if (= (length list) 4)
(rewrite-sexp-expr (cadddr list))
`(%progn ,@(mapcar #'rewrite-sexp-expr
(cdddr list))))))
`(%define (%quote ,name)
(%lambda ,name ,params ,body))))
((eq (car list) 'dolist)
(let ((elm (cadr list))
(in-list (rewrite-sexp-expr (caddr list)))
(body (rewrite-sexp-expr (cadddr list))))
`((%lambda
dolist
(_rec in-list)
(_rec in-list))
(%lambda dolist-rec (lst)
(if lst
((%lambda inder-rec (,elm)
(%progn
,body
(_rec (cdr lst)))))
nil))
,in-list)))
(t (mapcar #'rewrite-sexp-expr list))))
 
(defun rewrite-sexp-expr (body)
(typecase body
(list (rewrite-sexp-expr-list body))
(t body)))
 
(defmacro sexp-to-memory* (&body body)
`(sexp-to-memory
,(car body)
 
,@(loop for a in (cdr body)
collect (rewrite-sexp-expr a))))
 
 
(defmacro sexp-to-memory (&body body)
(let ((sexpvar (gensym)))
`(let* ((*symbolinfopos* 0)
(outlist ())
(symbols (loop for sym in ',(car body)
for i from 0
do (setf *symbolinfopos* i)
collect (cons sym i))))
(setf *symbolinfopos* *symbolstartpos*)
(with-open-file (out
"/tmp/initmem"
:element-type 'character
:direction :output
:if-does-not-exist :create
:if-exists :supersede)
(let ((pos 0)
(*symbolinfo* symbols))
(loop for ,sexpvar in ',(cdr body)
do (cond ((keywordp ,sexpvar)
(let ((addr (parse-integer (format nil "~A" ,sexpvar) :radix 16)))
(setf outlist (append outlist (list (format nil "~%addr ~X~%" addr))))
(format t "Changing address from 0x~X to 0x~X~%" pos addr)
(setf pos addr)))
(t
(multiple-value-bind (special list num)
(sexp-to-memory-fun ,sexpvar)
(declare (ignore special))
(incf pos num)
(setf outlist (append outlist (listify list)))))))
 
 
(let* ((newsymbols (nthcdr (length ',(car body)) *symbolinfo*)))
(let* ((sympos (+ *symbolstartpos* (length newsymbols)))
;; Build symbols and symbol names
(symbols
(loop for (sym . pos) in newsymbols
collect (multiple-value-bind (special b c)
(sexp-to-memory-fun (format nil "~A" sym))
(declare (ignore special))
(format t "Increasing sympos by: ~A for ~A~%" c sym)
(let ((sympos* sympos))
(incf sympos c)
(list b (format nil "symbol ~X ~A" sympos* sym))))))
(dataposition sympos)
(symboltable-start dataposition)
;; Build symboltable
(symboltable (multiple-value-bind (special data len)
(sexp-to-memory-fun (mapcar #'car newsymbols))
(declare (ignore special))
;; Link it up against the cpu symboltable
(setf (nth (1- (length data)) data) "snoc E00")
(incf dataposition (length data))
data))
(environment-position dataposition)
;; Build our environment
(env (let ((env* (list "cons +2" "snoc 0"
"cons +2" "snoc 0"
(format nil "cons ~X" (multiple-value-bind (special data len)
(handle-symbol '%symbol-table)
(declare (ignore special len))
data))
(format nil "snoc ~X" symboltable-start))))
(incf dataposition (length env*))
env*)))
 
(let ((curpos *datastartpos*))
(flet ((printinc ()
;(format out "# Add ~X~%" curpos)
(incf curpos)))
 
;; Intial setup, start address. Pointer to expression and environment
(format out "addr ~X~%" *datastartpos*)
(format out "start ~X~%" *datastartpos*)
(printinc)
(format out "cons ~X~%" dataposition)
(printinc)
(format out "snoc ~X~%" environment-position)
;; Symbols
(format out "# Symbols~%")
(dolist (sym (mapcar #'second symbols))
(printinc)
(format out "~A~%" sym))
;; Symbol names
(format out "# Symbol names~%")
(dolist (name (mapcar #'first symbols))
(dolist (elem name)
(printinc)
(format out "~A~%" elem)))
 
;; Symbol table
(format out "# Symboltable~%")
(dolist (elem symboltable)
(printinc)
(format out "~A~%" elem))
;; Environment
(format out "# Environment~%")
(dolist (elem env)
(printinc)
(format out "~A~%" elem))
;; Program
(format out "# Program~%")
(dolist (a outlist)
(printinc)
(format out "~A~%" a)))))))))))
 
#|
(sexp-to-memory
(nil t if)
(define read (lambda (str) #\b t)))
|#
/microprogram_assembler/some.lisp
0,0 → 1,7
(%LAMBDA (ARGS)
(%IF ARGS
(%IF (%EQ? (%QUOTE %.) (%CAR ARGS))
(%CAR (%CDR ARGS))
(%CONS (%CAR ARGS)
(REC (%CDR ARGS))))
nil))
/microprogram_assembler/README
0,0 → 1,32
HOW TO USE THE MICROCODE ASSEMBLER
 
Start SLIME:
 
M-x slime
 
Load the assembler (replace string by correct path):
 
(push "/home/oystein/ntnu/lispm/lispm/mcasm/" asdf:*central-registry*)
(asdf:operate 'asdf:load-op :mcasm)
OR
(require 'mcasm) [ only for sbcl ]
 
Enter the MCASM package (in SLIME REPL buffer):
 
, change-package RET mcasm RET
OR <RET>
,!p <RET> mcasm <RET>
 
Open and load microprogram source file:
 
C-x C-f microprogram.lisp RET
C-c C-l RET
 
Assemble it (from SLIME REPL buffer):
 
To make a microcode file for the simulator, use:
(write-microprogram :output-format :simulator)
 
To make a microcode file for the emulator, use:
 
(write-microprogram :output-format t)
/microprogram_assembler/README-asm-emu.txt
0,0 → 1,24
how to do some stuff
====================
 
Generate register file from microprogram:
 
load microprogram.lisp into emacs, run it with C-c C-l
in slime-repl buffer, run (write-register-file)
 
Generate memory file:
 
load sexptomem.lisp, run it
load bootprogram.lisp, run it
 
create a text file "keyboard" with commands
 
 
in emulator, make run
 
 
in another window:
 
tail -f screen
 
to view the output
microprogram_assembler/README-asm-emu.txt Property changes : Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.