;; a test for template linking. firstly compiled template calls secondly compiled template
;;
;; first *test-b0*
;; then *test-b1* or *test-b11*
;;
;; b0 + b1 is the key scancode displayer
;; b0 + b11 is a very basic test of linking functionality


(setf *test-b0*      
'(let ()
       
   (defun not (x)
     (if x nil -1))

   (defun next-i (i m)
     (addr-and (%+ i 1) m))

   (defun mod-m (i m)
     (if (%>= i m)
         (%- i m)
       i))


   (defun p-shiftl (x i)
     (do ((j 0 (%+ j 1)))
         ((%>= j i) x)
       (setq x (p-shiftl-1 x))))

   (defun p-shiftr (x i)
     (do ((j 0 (%+ j 1)))
         ((%>= j i) x)
       (setq x (p-shiftr-1 x))))

   (defun irq (x)
     (let ((ch (get-word (p-constr 57344 0) 8))
           (getpt (get-word 100 0))
           (insrtpt (get-word 100 4)))
       (set-word 110 insrtpt ch)
       (let ((insrtpt1 (next-i insrtpt 15)))
         (if (not (%= insrtpt1 getpt))
             (set-word 100 4 insrtpt1)))
       (let ((s (get-status)))
         (set-status (addr-ior s 128))
         x)))

   (defun getch ()
     (let ((getpt (get-word 100 0))
           (insrtpt (get-word 100 4)))
       (if (%= getpt insrtpt)
           -1
         (let ((ch (get-word 110 getpt)))
           (set-word 100 0 (next-i getpt 15))
           ch))))


   (defun to-ascii (val)
     (if (%<= val 9)
         (%+ val 48)
       (%+ val 55)))

   (defun print-hex-digit (pos val)
     (set-byte base_vga (p-shiftl pos 2) (to-ascii val)))

   (defun print-hex-byte (pos val)
     (print-hex-digit (%+ pos 1) (addr-and val 15))
     (print-hex-digit pos (addr-and (tag-and (p-shiftr val 4) 0) 15)))


   (defun print-hex (pos val)
     (let ((v val))
       (print-hex-byte (%+ pos 6) (addr-and (p-shiftl val 2) 255))
       (print-hex-byte (%+ pos 4) (addr-and (setq v (tag-and (p-shiftr v 6) 0)) 255))
       (print-hex-byte (%+ pos 2) (addr-and (setq v (tag-and (p-shiftr v 8) 0)) 255))
       (print-hex-byte pos (addr-and (tag-and (p-shiftr v 8) 0) 255))))

   (defun set-irq-fun (fun)
     (set-word (p-constr 0 16) 0 (%symbol-function fun)))

   (set-irq-fun 'irq)

   (setq base_vga (p-constr 61440 0))
   (setq base_sram (p-constr 53248 0))
   (setq base_ctrl (p-constr 57344 0))

   (setq base_low (p-constr 0 0))

   (set-word 100 0 0) ; getpt
   (set-word 100 4 0) ; insrtpt


   (if (%= (get-word 50 0) 1)
       (let ((fun (%make-closure (get-word 50 4) nil)))
         (funcall fun)))
         
))



;; second template

;; full version

(setf *test-b1*
'(let ()
   (do ((out-pos 0 out-pos)
        (i 0 (%+ i 1)))
       (nil)
     (let ((ch (getch)))
       (print-hex 5320 i)
       (if (not (%= ch -1))
           (progn 
             (print-hex out-pos ch)
             (setq out-pos (mod-m (%+ out-pos 19) 5320))))))))


;; simple test version

(setf *test-b11*
'(let ()
   (%print 22)
   (%print 23)
   (%print (p-shiftr-1 (p-shiftr-1 base_vga)))))




;; a test for the (crudely implemented) values, multiple-value-bind feature
;; note the necessity to have the magic variables valuescntq and valuesq initialized
;; at the beginning. these are never allowed as user variables if values is to be used
;;


(setf *test-b2*
'(let ()

   (setq valuescntq -1)
   (setq valuesq (%make-vector 20))

   (defun f (n)
     (values n (%+ n n) (%+ n 23)))

   (multiple-value-bind (a b c) (f 70)
     (%print a)
     (%print b)
     (%print c))

   (multiple-value-bind (a b c d) (values 1 2
                                          (multiple-value-bind (x y) (values 3 4) (%+ x y)) 5)
     (%print a)
     (%print b)
     (%print c)
     (%print d))

   (multiple-value-bind (a b c d) (values 1 2
                                          (values 37 38) 3)
     (%print a)
     (%print b)
     (%print c)
     (%print d))))