(in-package "MESYSTEM")

; defuna


(defun translate (arg)
  (cond ((cl:listp arg) (mapcar #'(lambda (z) (translate z)) arg))
        ((cl:numberp arg) (cl-fixnum arg))
        (t arg)))

(defmacro defuna (&rest body)
  `(defun ,@(translate body)))

(defmacro defparametera (&rest body)
  `(defparameter ,@(translate body)))







; neu zu definierende Kontrollstrukturen im Interpreter



; vergleichsfunktionen allgemein


(defuna null (x)
  (eq x nil))

(defuna atom (x)
  (not (consp x)))

; logische funktionen


(defuna not (x)
  (cond ((null x) t)
        (t nil)))



; die conses, lese und schreibfunktionen


(defuna cons (x y)
  (let ((p (%allocate-space 8)))
    (set-word p 0 x)
    (set-word p 4 y)
    (setf p (tag-set p 1))
    p))


(defuna car (x)
  (if (null x)
        nil
      (get-word x 0)))
     

(defuna cdr (x)
  (if (null x)
      nil
    (get-word x 4)))


(defuna set-car (x v)
  (set-word x 0 v))


(defuna set-cdr (x v)
  (set-word x 4 v))

; die conses, testfunktionen

(defparametera *cons-tag* 1)

(defuna consp (x)
  (tag-eq x *cons-tag*))

(defuna listp (x)
  (or (null x) (consp x)))



; die strings, lesen und schreiben von zeichenpositionen


(defparametera *string-head-tag* 2)
(defparametera *string-tag* 2)

(defuna make-string (n)
  (let ((len (%div (%align n 2) 4)))
    (let ((n-align (%align (%+ (%* len 4) 8) 3)))
      (let ((p (%allocate-space n-align)))
        (set-word p 0 (tag-set (addr-ior (p-shiftl n-align 2) 1) *string-head-tag*))
        (set-word p 4 n)
        (do ((i 0 (%+ i 1)))
            ((%>= i n))
          (set-char p i (code-char 0)))
        (setq p (tag-set p *string-tag*))
        p))))
        

(defuna char (str i)
  (let ((byte-val (get-byte str (%+ i 8))))
    (code-char byte-val)))

(defuna set-char (str i c)
  (let ((byte-val (char-code c)))
    (set-byte str (%+ i 8) byte-val)))


; die strings, testfunktionen


(defuna stringp (x)
  (and (tag-eq x *string-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 0)
          (tag-eq h *string-head-tag*)))))
          


; die strings, vergleichsfunktionen

(defuna length (s)
  (if (or (stringp s) (arrayp s))
      (get-word s 4)
    -1))
        

(defuna string< (x y)
  )

(defuna string> (x y)
  )

(defuna string= (x y)
  )

(defuna string-cmp-code (x y)
  (let ((len-x (length x))
        (len-y (length y))
        (res-code 0))
    (do ((i 0 (%+ i 1)))
        ((or (%>= i len-x) (%>= i len-y) (%/= res-code 0)) res-code)
      (let ((cc-1 (char-code (char x i)))
            (cc-2 (char-code (char y i))))
        (if (%< cc-1 cc-2)
            (setq res-code -1)
          (if (%> cc-1 cc-2)
              (setq res-code +1)))))
    (if (%= res-code 0)
        (cond ((%< len-x len-y) -1)
              ((%= len-x len-y) 0)
              ((%> len-x len-y) +1))
      res-code)))

(defuna get-hash (str n)
  (let ((len (length str))
        (res 2))
    (do ((i 0 (%+ i 2)))
        ((%>= i (%- len 1)) (%rem res n))
      (setq res (%rem (%+ res (%+ (char-code (char str i)) (%* (char-code (char str (%+ i 1))) 256))) n)))))


; die vectoren, lesen und schreiben von elementen

(defparametera *array-head-tag* 1)
(defparametera *array-tag* 2)
(defparametera *array-lead* 12)


(defuna make-vector (n)
  (let ((n-bytes (%align (%+ (%* 4 n) *array-lead*) 3)))
    (let ((p (%allocate-space n-bytes)))
      (set-word p 0 (tag-set (addr-ior (p-shiftl n-bytes 2) 1) *array-head-tag*))
      (set-word p 4 n)
      (set-word p 8 0)
      (do ((i 0 (%+ i 1)))
          ((%>= i n))
        (set-svref p i nil))
      (setq p (tag-set p *array-tag*)))))

(defuna svref (vect i)
  (get-word vect (%+ (%* i 4) *array-lead*)))

(defuna set-svref (vect i val)
  (set-word vect (%+ (%* i 4) *array-lead*) val))


; die vectoren, testfunktionen

(defuna arrayp (x)
  (and (tag-eq x *array-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 0)
          (tag-eq h *array-head-tag*)))))




; die chars

(defparametera *char-mark* 0)
(defparametera *char-tag* 3)


(defuna char-code (c)
  (p-shiftr c 14))

(defuna code-char (x)
  (tag-set (p-shiftl x 14) *char-tag*))

(defuna characterp (x)
  (tag-eq x *char-tag*))



; die atome


(defparametera *symbol-head-addr* 3)
(defparametera *symbol-head-tag* 2)
(defparametera *symbol-tag* 2)


(defuna make-symbol (str)
  (let ((p (%allocate-space 24)))
    (set-word p 0 (tag-set *symbol-head-addr* *symbol-head-tag*))
    (set-word p 4 str)
    (set-word p 8 nil)
    (set-word p 12 nil)
    (set-word p 16 nil)
    (set-word p 20 nil)
    (tag-set p *symbol-tag*)))

(defuna intern (str)
  (let ((hash-val (get-hash str *base-pkg-len*)))
    (let ((slot (svref *base-pkg* hash-val))
          (p-old nil)
          (p-akt nil)
          (str-cmp-val -1)
          (test-str str))
      (do ((akt-atom slot (cdr akt-atom)))
          ((or (null akt-atom) (%>= str-cmp-val 0)))
        (setq str-cmp-val (string-cmp-code str (symbol-name (car akt-atom))))
        (setq p-old p-akt)
        (setq p-akt akt-atom))
      (cond ((%= 0 str-cmp-val)
             (car p-akt))
            ((%>= str-cmp-val 0)
             (let* ((new-sym (make-symbol str))
                    (new-holder (cons new-sym p-akt)))
               (set-symbol-package new-sym *base-pkg*)
               (if (null p-old)
                   (let ()
                     (set-svref *base-pkg* hash-val new-holder))
                 (set-cdr p-old new-holder))
               new-sym))
            ((%< str-cmp-val 0)
             (let* ((new-sym (make-symbol str))
                    (new-holder (cons new-sym nil)))
                (set-symbol-package new-sym *base-pkg*)
                (if (null p-akt)
                    (let ()
                      (set-svref *base-pkg* hash-val new-holder))
                  (set-cdr p-akt new-holder))
                new-sym))))))


; die atom attribute, lesen

(defuna symbol-name (sym)
  (get-word sym 4))

(defuna symbol-value (sym)
  (get-word sym 8))

(defuna symbol-function (sym)
  (get-word sym 12))

(defuna symbol-plist (sym)
  (get-word sym 16))

(defuna symbol-package (sym)
  (get-word sym 20))

; die atom attribute, schreiben

(defuna set-symbol-value (sym val)
  (set-word sym 8 val))

(defuna set-symbol-function (sym val)
  (set-word sym 12 val))

(defuna set-symbol-plist (sym val)
  (set-word sym 16 val))

(defuna set-symbol-package (sym val)
  (set-word sym 20 val))


; die atome, testfunktion

; symbol hat |10 als tag im zeiger und 1|00 im header


(defuna symbolp (x)
  (and (tag-eq x *symbol-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 2)
          (tag-eq h *symbol-head-tag*)))))



; die (fix)nums

(defparametera *fixnum-tag* 0)

  
(defuna numberp (x)
  (tag-eq x *fixnum-tag*))


(defuna %align (x i)
  (p-shiftl (p-align (p-shiftr x 2) i) 2))


; die closures

(defparametera *closure-head-addr* 3)
(defparametera *closure-head-tag* 1)
(defparametera *closure-tag* 2)
(defparametera *closure-slots* 2)

(defuna make-closure (templ vect)
  (let ((p (%allocate-space (%+ (%* *closure-slots* 4) 8))))
    (set-word p 0 (tag-set *closure-head-addr* *closure-head-tag*))
    (set-closure-ref p 0 templ)
    (set-closure-ref p 1 vect)
    (setq p (tag-set p *closure-tag*))
    p))


(defuna closure-ref (cl i)
  (get-word cl (%+ 4 (%* i 4))))

(defuna set-closure-ref (cl i x)
  (set-word cl (%+ 4 (%* i 4)) x))

(defuna closurep (x)
  (and (tag-eq x *closure-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 2)
          (tag-eq h *closure-head-tag*)))))



; die templates

(defparametera *template-head-tag* 3)
(defparametera *template-tag* 2)

(defparametera *template-leader* 4)

; d und c sind anzahl von 32 bit worten

(defuna make-template (d c)
  (let ((n-bytes (%align (%+ (%* (%+ d c) 4) (%* 4 *template-leader*)) 3)))
    (let ((p (%allocate-space n-bytes)))
      (set-word p 0 (tag-set (addr-ior (p-shiftl n-bytes 2) 1) *template-head-tag*))
      (set-word p 4 (p-add p (%+ (%* *template-leader* 4) (%* d 4))))
      (set-word p 8 d)
      (set-word p 12 c)
      (do ((i 0 (+ i 1)))
          ((%>= i d))
        (set-templ-ref-d p i nil))
      (do ((i 0 (+ i 1)))
          ((%>= i c))
        (set-templ-ref-c p i 0 0))
      (setq p (tag-set p *template-tag*))
      p)))

(defuna length-d (templ)
  (get-word templ 8))

(defuna templ-ref-d (templ i)
  (get-word templ (%+ (%* *template-leader* 4) (%* i 4))))


(defuna templ-ref-c (templ i)
  (let ((pc (get-word templ 4)))
    (get-word pc (%* i 4))))


(defuna set-templ-ref-d (templ i val)
  (set-word templ (%+ (%* *template-leader* 4) (%* i 4)) val))

(defuna set-templ-ref-c (templ i v-high v-low)
  (let ((pc (get-word templ 4)))
    (set-word pc (%* i 4) (p-constr v-high v-low))))



(defuna templatep (x)
  (and (tag-eq x *template-tag*)
       (let ((h (get-word x 0)))
         (and
          (addr-eqi (addr-and h 2) 0)
          (tag-eq h *template-head-tag*)))))




; allgemeiner heap allokator. ruft (später: inkrementellen) garbage collector auf


(defuna %allocate-space (n)
  (let ((ret *alloc-pointer*))
    (setf *alloc-pointer* (+ *alloc-pointer* (p-shiftr n 2)))
    ret))





; system-erzeugung



; tests


(defparametera *base-pkg-len* 53)
(setf *base-pkg* (make-vector *base-pkg-len*))

;(setf str (cl-string "juergen"))



; tests

(setf *type-fun-l* '(consp listp symbolp numberp characterp stringp arrayp closurep templatep))

(defun show-types (x)
  (loop for f in *type-fun-l* do
        (format t "~S (~S) = ~S~%" f x (funcall (cl:symbol-function f) x))))


(setf *tst-l* (cl:list 1 #\a (cl:cons 2 3) 'utz (cl:make-array 5) "juergen" ))



(intern (cl-string "read-error"))
(intern (cl-string "next"))
(intern (cl-string "same"))
(intern (cl-string "peek"))

(mapcar #'(lambda (z) (intern (cl-string z)))
        '("cond" "labels" "let" "setq" "progn" "do" "do-until" "funcall" "funarg" "car" "cdr" "cons" "eq" "defun"
                 "+" "-" "*" "divrem" ">" "<" "=" ">=" "<=" "null" "atom"))