URL
https://opencores.org/ocsvn/igor/igor/trunk
Subversion Repositories igor
[/] [igor/] [trunk/] [microprogram_assembler/] [bootprogram.lisp] - Rev 3
Compare with Previous | Blame | View Log
;;;(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-statusxxxaaxxxabxxxacxxxadxxxaexxxafxxxagxxxahxxxaixxxajxxxak%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 chpeekchpeek(%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 chpeekchpeek(%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?sizepos)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*(%lambdastring-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(%lambdastring-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-slicefiletable-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+ (%mulindex+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 1file-info+fileinfo-current-pos+(1+ (%array-get file-info +fileinfo-current-pos+)))(%if (end-of-block file-info) ;if end of block...(%progn(%array-setfile-info+fileinfo-block+(file-next-block(%array-get file-info +fileinfo-block+))) ;find the next block and set(%array-setfile-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 (%addaddr+filetable-field-filename+)filename)(put-char-at-addr (%addaddr+filetable-field-start-block+)(%int-to-char (find-free-block)))(put-char-at-addr (%addaddr+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(%mulentry(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+);...ehindex ;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(%lambdaintern-char-hash (ch)(%bitwise-and (%char-to-int ch) 7)))(%define'intern-make-node(%lambdaintern-make-node ()(%cons nil (%make-array 8 nil))))(%define'intern-get-node(%lambdaintern-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(%lambdaintern-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(%lambdaintern-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-symbolexisting-symbol(%make-symbol str))(%car tree))))))(intern-recstr(%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(%lambdaintern (str)(intern-rec str 0 symbol-tree nil)))(%define'intern-symbols(%lambdaintern-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-integerlist->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 toktok(%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(%lambdaprint-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(%lambdaprint-builtin (b)(%progn(%put-char current-output #\#)(%put-char current-output #\()(print (%builtin-name b))(%put-char current-output #\)))));; Print an object(%define(%lambdaprint (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(%lambdacombine (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?(%lambdaigorev-state-huge-success? (state)(%eq? (igorev-state-condition state) nil)))(%define'igorev-state-result(%lambdaigorev-state-result (state)(igorev-eval-frame-result(igorev-func-frame-eval-frame(igorev-state-func-frame state)))))(%define'igorev-state-expr(%lambdaigorev-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(%lambdafunction-name (f)(%car (%function-data f))))(%define'function-param-list(%lambdafunction-param-list (f)(%cadr (%function-data f))))(%define'function-expr(%lambdafunction-expr (f)(%caddr (%function-data f))))(%define'function-env(%lambdafunction-end (f)(%cadddr (%function-data f))))(%define'show-error-message(%lambdashow-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(%lambdadisplay (str)(%progn(%define'display-rec(%lambdadisplay-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(%lambdacatch-macro (root)(let ((cond-var (cadr root)))(let ((handlers (caddr root)))(let ((body (cdddr root)))(list 'catch-fn(cons'list(map (%lambdacatch-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(%lambdaquit () ; 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(%lambdalooptyloop ()(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)))