Subversion Repositories igor

;;;
;;; 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)))
|#