;;;                             asm-let.s                             12/16/91
;;; 
;;; This function essentially implements the first pass of the assembler as
;;; a macro expansion. The idea is to generate strings of code that may be 
;;; sent to the assembler at run-time and copied very quickly. The opcode
;;; translation, relative jump offsets etc. will be computed at expand-time.
;;;
;;; Last Edit:
;;;  Boyer   12/16/91 - Created
;;;
;;; Notes:
;;;
;;; The syntax should be used as follows:
;;; (define fun
;;;   (asm-let ((v1 (opc CS:) (opc lds (DW W) BX) ...)
;;;             (v2 ...)
;;;             ...)
;;;
(define pre-lets ())
(define pre-sets ())
(define add-preset
  (lambda (e)
    (set! pre-sets (cons e pre-sets))))
(define add-prelet
  (lambda (e)
    (unless (assq (car e) pre-lets)
	    (set! pre-lets (cons e pre-lets)))))
(let () ;;; This should be above. Put here for debuging
(define asm-link-byte
  (lambda (byte)
    (cond
      ((number? byte) (code-byte byte))
      ((symbol? byte)
       (cond
         ((eq? byte '.align-long) (add-preset '(\#code-align-4)))
         ((eq? byte '.align-para) (add-preset '(\#code-align-16)))
         (else
           (error 'asm-link-byte "Bad asm directive: ~s" byte))))
      ((string? byte)
       (for-each code-byte (map char->integer (string->list byte)))) 
      ((char? byte) (code-byte (char->integer byte)))
      (else (error 'asm-link-byte " bad input: ~s" byte)))))

(define asm-link-pair
  (lambda (l name)
    (let ((key (car l))
          (data (cadr l))
          (data2 (if (null? (cddr l)) () (caddr l))))
      (case key
        (ib  (code-byte data))
        (iw  (code-word (unsign.word data)))
	(iwv (add-preset
	      `(\#csw! ,name ,%asm-p1-code-index ,data))
	     (code-byte 0)
	     (code-byte 0))
	(ibv (add-preset
	      `(\#csb! ,name ,%asm-p1-code-index ,data))
	     (code-byte 0))
	(isw (code-word (sign.word->unsign.word data)))
	((aw aw100 dw ag)
         (add-preset 
	  `(\#destination-label! ',key ,data (fx+ ,%asm-p1-code-index %asm-p1-code-index)))
	 (add-prelet `(,data (make-label)))
         (code-byte 0)
         (code-byte 0))
        (db
         (add-preset
	  `(\#destination-label! ',key ,data (fx+ ,%asm-p1-code-index %asm-p1-code-index)))
         (code-byte 0))
        (l 
         (add-preset `(\#source-label! ,data (fx+ ,%asm-p1-code-index %asm-p1-code-index)))
	 (add-prelet `(,data (make-label))))
	(l* ;;; Label does not need to be created, it is in local scope
	 (add-preset `(\#source-label! ,data  (fx+ ,%asm-p1-code-index %asm-p1-code-index))))
	(el
         (add-preset `(\#source-label! ,data ,data2))
	 (add-prelet `(,data (make-label))))
        (dl
	 (add-preset
	  `(let ((ref (disp-lookup-label ,data2)))
	     (\#source-label! ,data
			     (fx- (fx+ ,%asm-p1-code-index %asm-p1-code-index) ref)))))
	(sp 
         (add-preset `(\#destination-label! ',key (fx+ ,%asm-p1-code-index %asm-p1-code-index)))
         (code-byte 0)
         (code-byte data)
         (code-word 0))
        (sa
         (case data
           (()              (code-word #x0100) (code-word 0))
           (|#undefined|    (code-word #x0200) (code-word 0))
           (|#unspecified|  (code-word #x0300) (code-word 0))
;          (|#f|            (code-word 0) (code-word 0))
           (#f              (code-word 0) (code-word 0))
           (#t              (code-word #xff) (code-word 0))
	   (else
	    (cond
	     ((char? data)
	      (code-word #x0600) 
	      (code-word (char->integer data)))
	     ((number? data)
	      (code-word #x0800)
	      (code-word (sign.word->unsign.word data)))
	     (else (error 'asm-link-pair " bad sa type ~s" data))))))
        (ss
         (let ((size (ss-list-size (cdr l)))
               (slist (ss-list-gen (cdr l))))
           (code-word #x3000)
           (code-word size)
           (for-each code-byte slist)
	   (code-byte 0)))
	(c #t)  ;comment	 
	(else
          (error 'asm-link-pair "bad code ~s" l))))))

(define asm-p1-pre
  (lambda (l name)
    (letrec ((asm-p1
	      (lambda (l)
		(cond
		 ((null? l) #t)
		 ((atom? l) (asm-link-byte l))
		 ((and (pair? l) (null? (cdr l))) (asm-p1 (car l))) 
		 ((and (pair? l) 
		       (symbol? (car l))
		       (not (eq? (car l) '.align-long))
		       (not (eq? (car l) '.align-para)))
		  (asm-link-pair l name))
		 ((pair? l)
		  (asm-p1 (car l))
		  (asm-p1 (cdr l)))
		 (else (error 'asm-p1 "bad input exp: ~s" l))))))
      (for-each 
       (lambda (x)
	 (cond
	  ((not (pair? x)) (asm-p1 x))
	  ((memq (car x)
		 '(iw iwv db dw l l* aw aw100 isw ib ibv sp sa ss ag el dl))
	   (asm-p1 x))
	  (else (asm-p1 (apply opc-fn x)))))
       l))))

(set! asm-let-expander
  (letrec
     ((asm-bps
       (lambda (bps)
	 (set! pre-lets ())
	 (let loop ((bps bps)(ans ()))
	   (if (null? bps)
	       (reverse ans)                  ;;; Not stricly necessary
	       (let ((name (caar bps))
		     (code-exps (cdar bps)))
		 (code-open)
		 (set! pre-sets ())           ;;; Should be in code-open
		 (asm-p1-pre code-exps name)
		 (let ((cs (code-list->string code)))
		   (loop (cdr bps)
			 (cons (list (list name cs) pre-sets)
			       ans)))
		 )))))
      (code-list->string (lambda (x) (list->string (map integer->char x))))
      (do-subst
       (lambda (bps exps)
	 (let loop ((bps bps)(exps exps))
	   (if (null? bps)
	       exps
	       (loop (cdr bps)
		     (subst (make-preset (cadar bps) (caaar bps))
			    (caaar bps) exps))))))
      (make-preset
       (lambda (set-exps name)
	 (cons 'begin (append (reverse set-exps) (list name)))))
      )

    (lambda (bps fps exps)
	(let ((new-bps (asm-bps bps)))
	  `(let ,(map car new-bps)
	     (lambda ,fps
	       (let ,pre-lets
		 . ,(do-subst new-bps exps)))))
    )))


) ;;; let ()

(extend-syntax (asm-let lambda)
  ((asm-let bps
      (lambda fps . exps))
   (with ((expansion (asm-let-expander 'bps 'fps 'exps)))
     expansion)))

(define test
  `(asm-let ((c1 (l begin*)
		 (CS:)
		 (lds (dw w) ax)
		 (aw test1)
		 (IWV (fx+ offset LCO-Header-Size))
		 (dl test1 begin*))
	     (c2 (CS:)
		 (jnz)
		 (db test2)
		 (lds (dw w) ax)
		 (l test2)
		 (IWV (fx+ offset LCO-Header-Size))))
     (lambda (offset)
       (if (zero? offset)
	   (asm-p1-string c1)
	   (asm-p1-string c2)))))