;;;                             asm88v3.s                              6/10/91
;;;                        scheme 8088 assembler
;;;
;;; Scheme 8088 assembler used by the runtime system. This code differs from
;;;  asm2.s in it's use of fixnum arithmetic. Also, code objects are 
;;;  represented by byte-vectors as of 9/91 to speed up assembly and reduce
;;;  memory usage.
;;;
;;;
;;; Last Edit:
;;;  Boyer  1/92 - Changed code abstraction to asm-p1-string, which keeps track
;;;                of the code object, length, buff-size, etc. This will be written
;;;                as a BCO for speed.
;;;  Boyer 12/91 - Changed labels so that the value and location pairs are 
;;;                 stored in the symbol thus eliminating the need to do a
;;;                 search when any label operation is done.
;;;  Boyer  9/91 - Changed assembler to assemble to code-vector objects instead
;;;                 of lists.
;;;  Hunt   6/91 - Created
;;;
;;; 

;;; the following functions are inlined by passp
;
;(define q4 (lambda (x) (quotient x 4)))
;(define q16 (lambda (x) (quotient x 16)))
;(define q256 (lambda (x) (quotient x 256)))
;(define m4 (lambda (x) (modulo x 4)))
;(define m16 (lambda (x) (modulo x 16)))
;(define m256 (lambda (x) (modulo x 256)))
;(define sign.word->unsign.word
;  (lambda (x)
;    (if (or (< x -32768) (> x 32767))
;	(error 'sign.word->unsign.word " signed word too big")
;	(if (< x 0) (fx+ x 65536) x))))

(define \#code-open
  (lambda n
    (set! label-list ())
    (asm-p1-string (if (null? n) 4000 (car n)))))

(define \#code-align-4
  (let ((fill-vec #4("" "���" "��" "�")))
    (lambda ()
      (asm-p1-string (vector-ref fill-vec (m4 %asm-p1-code-index))))))

(define \#code-align-16
  (let ((fill-vec #16("" 
		      "���������������"
		      "��������������"
		      "�������������"
		      "������������"
		      "�����������"
		      "����������"
		      "���������"
		      "��������"
		      "�������"
		      "������"
		      "�����"
		      "����"
		      "���"
		      "��"
		      "�")))
  (lambda ()
    (asm-p1-string (vector-ref fill-vec (m16 %asm-p1-code-index))))))

(define \#code-byte
  (lambda (b)
    (asm-p1-string (integer->char b))))

(define \#code-word
  (lambda (w)
    (asm-p1-string (integer->char (m256 w)))
    (asm-p1-string (integer->char (q256 w)))))

(define \#csw!   ;;; Code-set-word!
  (lambda (str off w)
    (let ((word (sign.word->unsign.word w)))
      (string-set! str off (m256 word))
      (string-set! str (fxadd1 off) (q256 word))
      )))

(define \#csb!   ;;; Code-set-word!
  (lambda (str off w)
    (string-set! str off w)))

;
;  storage for labels
;
(define \#label-list '())
;
;  label-list format:   (label-element1 label-element2 ...)
;  label-element:   ::= label-symbol                        ** A gensym **
;                        ----------------------------------
;  label-symbol     ::= | val | not-linked | location-list |
;                        ----------------------------------
;  val              ::= fixnum
;  not-linked       ::= fixnum | #f
;  location-list:   ::= (lpair1 lpair3 ...)
;  lpair:           ::= (type location)
;  type             ::= aw | aw100 | dw | db | ag | sp | 
;  location         ::= fixnum
;
;(define disp-lookup-label
;  (lambda (label)
;    (if (eq? (symbol->value label) '|#undefined|)
;	(error 'disp-lookup-label 
;	       " disp. label reference "label" not defined")
;	(symbol->value label))))

(define \#destination-label!
  (lambda (type label loc)
    (let ((not-linked? (symbol->string label))
	  (lp (%proplist label)))
      (when not-linked?                            ;;; Label not in label list
	 (set! label-list (cons label label-list)) ;;; Add it to label-list
	 (set-cdr! label #f))                      ;;; Mark label as linked
      (%set-proplist! label                        ;;; Add location-pair to
		      (cons                        ;;; this label
		       (list type loc)
		       lp)))))

(define \#source-label!
  (lambda (label loc)
    (let ((not-linked? (symbol->string label))
	  (val (symbol->value label))
	  (lp (%proplist label)))
      (when not-linked?                            ;;; Label not in label list
        (set! label-list (cons label label-list))  ;;; Add it to label list
	(set-cdr! label #f))                       ;;; Mark label as linked
      (if (eq? (symbol->value label) '|#undefined|);;; Location not set before
	  (set-car! label loc)                     ;;; Set The location
	  (error 'link-label "Label already defined")))))

;
;
; assembler pass 1   add input to code storage and label storage
;
; input format:
;    number 00-FF    treated as 1 byte of code
;    (00-FF 00-FF)   treated as 2 bytes of code
;    string: "??"    converted to bytes
;    (ss "??" #)     scheme fixnum sized string
;    (sp type label) scheme pointer  16 bit segment, 8 bit type, 4 bit offset
;    (sa value)      scheme atom  #f=(sa |#f|) #t=(sa #t) ()=(sa ()) 12=(sa 12)
;    char: #\x       converted to 1 byte of data
;    (ib 00-FF)      treated as immediate data byte
;    (iw 0000-FFFF)  treated as signed 2 immediate bytes
;    (aw label)      absolute label as 2 bytes
;    (aw100 label)   absolute word label + 0100 for .com
;    (ag label)      absolute segment  NOTE: label must be para. aligned
;    (dw label)      displacement label as 2 bytes
;    (db label)      displacement label as 1 byte
;    (l label)       label definition at current location
;    (dl lab1 lab2)  disp label definition: lab1 = current loc - lab2
;                    NOTE: lab1 must already be defined
;    (c e1 e2 ...)   comment  e1 e2 ... are ignored
;    .align-long     aligns code with 4 byte boundary
;    .align-para     aligns code with 16 byte boundary
;

;(define asm-p1
;  (letrec
;      ((ss-list-size
;	(lambda (l)
;	  (cond
;	   ((null? l) 0)
;	   ((number? (car l)) (add1 (ss-list-size (cdr l))))
;	   ((string? (car l))
;	    (fx+ (string-length (car l)) (ss-list-size (cdr l))))
;	   (else (error 'ss-list " bad type in sized string list " l)))))
;       (ss-list-gen
;	(lambda (l)
;	  (cond
;	   ((null? l) ())
;	   ((number? (car l)) (cons (car l) (ss-list-gen (cdr l))))
;	   ((string? (car l))
;	    (append (map char->integer (string->list (car l)))
;		    (ss-list-gen (cdr l))))
;	   (else (error 'ss-list " bad type in sized string list " l)))))
;       (asm-link-pair
;	(lambda (l)
;	  (let ((key (car l))
;		(data (cadr l))
;		(data2 (if (null? (cddr l)) () (caddr l))))
;	    (case key
;	      (ib (code-byte data))
;	      (iw (if (fixnum? data)
;		      (code-word data)
;		      (error 'asm-link-pair "Iw Not Fixnum")))
;	      (sp
;	       (destination-label! key data2 %asm-p1-code-index)
;	       (code-byte 0)
;	       (code-byte data)
;	       (code-word 0))
;	      (sa
;	       (case data
;		 (#f              (code-word 0)      (code-word 0))
;		 (#t              (code-word #xff)   (code-word 0))
;		 (|#undefined|    (code-word #x0200) (code-word 0))
;		 (|#unspecified|  (code-word #x0300) (code-word 0))
;		 (()              (code-word #x0100) (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)))
;	      (db
;	       (destination-label! key data %asm-p1-code-index)
;	       (code-byte 0))
;	      (l
;	       (source-label! data %asm-p1-code-index))
;	      ((aw aw100 dw ag)
;	       (destination-label! key data %asm-p1-code-index)
;	       (code-byte 0)
;	       (code-byte 0))
;	      (dl
;	       (let ((ref (disp-lookup-label data2)))
;		 (source-label! data (fx- %asm-p1-code-index ref))))
;	      (c #t)			;comment	 
;	      (else
;	       (error 'asm-link-pair "bad code ~s" l)))))))
;    (lambda (l)
;      (let loop ((l l))
;	(cond
;	 ((null? l) #t)
;	 ((fixnum? l) (code-byte l))
;	 ((string? l) (asm-p1-string l))
;	 ((symbol? l)
;	  (cond
;	   ((eq? l '.align-long) (code-align-4))
;	   ((eq? l '.align-para) (code-align-16))
;	   (else
;	    (error 'asm "Bad asm directive: ~s" l))))
;	 ((atom? l) (error 'asm "Bad asm atom: ~s" l))
;	 ((and (pair? l) (null? (cdr l))) (loop (car l))) 
;	 ((and (pair? l) 
;	       (symbol? (car l))
;	       (not (eq? (car l) '.align-long))
;	       (not (eq? (car l) '.align-para)))
;	  (asm-link-pair l))
;	 ((pair? l)
;	  (loop (car l))
;	  (loop (cdr l)))
;	 (else (error 'asm-p1 "bad input exp: ~s" l)))))))



;;;   assembler pass 2   resolve all labels

(define asm-p2
  (letrec
    ((code ())
;     (cv! (lambda (loc data) (%code-vector-set! code loc data)))
     (resolve-dest
      (lambda (v dest)
	(let ((key (car dest))
	      (loc (cadr dest)))
	  (cond
	   ((eq? key 'dw)
	    (let ((diff (fx- v (fx+ loc 2))))
	      (if (or (< diff -32768) (> diff 32767))
		  (error 'asm-p2 " word displacement too big")
		  (let ((dv (sign.word->unsign.word diff)))
		    (%code-vector-set! code loc (m256 dv))
		    (%code-vector-set! code (add1 loc) (q256 dv))))))
	   ((eq? key 'db)
	    (let ((diff (fx- v (fx+ loc 1))))
	      (if (or (fx< diff -128) (fx> diff 127))
		  (error 'asm-p2 " byte displacement too big")
		  (let ((dv (if (fx< diff 0) (fx+ diff 256) diff)))
		    (%code-vector-set! code loc dv)))))
	   ((eq? key 'sp)
	    (%code-vector-set! code loc (m16 v))
					;skip type byte
	    (%code-vector-set! code (fx+ 2 loc) (m256 (q16 v)))
	    (%code-vector-set! code (fx+ 3 loc) (q256 (q16 v))))
	   ((eq? key 'aw)
	    (%code-vector-set! code loc (m256 v))
	    (%code-vector-set! code (add1 loc) (q256 v)))
	   ((eq? key 'ag)
	    (if (= (m16 v) 0)
		(let ((segv (q16 v)))
		  (%code-vector-set! code loc (m256 segv))
		  (%code-vector-set! code (add1 loc) (q256 segv)))
		(error 'asm-p2 " absolute segment not paragraph aligned")))
	   ((eq? key 'aw100)
	    (%code-vector-set! code loc (m256 (fx+ v #x100)))
	    (%code-vector-set! code (add1 loc) (q256 (fx+ v #x100))))
	   (else
	    (error 'asm-p2 "bad lpair " dest))))))
     (resolve-source
      (lambda (le)
	(let ((v (symbol->value le))
	      (locl (%proplist le)))
	  (if (eq? v '|#undefined|)
	      (error 'asm-p2 " label not defined " le)
	      ;(for-each (lambda (dest) (resolve-dest v dest)) locl)
	      (llet loop ((l locl))
		    (when (pair? l)
		      (resolve-dest v (car l))
		      (loop (cdr l))))
	      ))))
       )
  (lambda ()
    (set! code (asm-p1-string))
;   (for-each resolve-source label-list)
    (llet loop ((l label-list))
       (when (pair? l)
	     (resolve-source (car l))
	     (loop (cdr l))))
    (set! label-list ())
    (let ((result code))
      (set! code ())
      result))))

;(define asm-p1-string
;  (let ((old asm-p1-string))
;    (lambda args
;      (apply old args))))

;(define asm-p1-string*
;  (letrec ((code ())
;	   (code-len 0)
;	   (buff-size 0)
;	   (code-open
;	    (lambda n
;	      (set! buff-size (if (null? n) 4096 (car n)))
;	      (set! code (%make-code-vector buff-size))
;	      (set! code-len 0)
;	      (set! label-list ())))
;	   (code-string
;	    (lambda (str)
;	      (let ((stop (string-length str)))
;		(if (fx< (fx+ code-len stop) buff-size)
;		    (unless (fxzero? stop)
;		      (llet loop ((i (fxsub1 stop))(j (fx+ code-len (fxsub1 stop))))
;			(%code-vector-set! code j (string-ref str i))
;			(if (fxzero? i)
;			    (set! code-len (fx+ code-len stop))
;			    (loop (fxsub1 i) (fxsub1 j)))))
;		    (begin (stretch-code-object!)
;			   (asm-p1-string str))))))
;	   (stretch-code-object!
;	    (lambda ()
;	      (unless (fx< buff-size 32767)
;		      (error 'asm-p1 "Code size limit exceeded"))
;	      (let ((tmp (%make-code-vector (fx* buff-size 2))))
;		(llet loop ((i (fxsub1 buff-size)))
;		      (%code-vector-set! tmp i (%code-vector-ref code i))
;		      (if (fxzero? i)
;			  (void)
;			  (loop (fxsub1 i))))
;		(set! code tmp)
;		(set! buff-size (fx* buff-size 2))))))
;  (lambda args
;    (cond
;     ((null? args) (%set-cvec-length! code code-len)
;		   (let ((result code))
;		     (set! code ())
;		     result))
;     ((number? (car args))
;      (code-open 4096))
;     ((string? (car args))
;      (code-string (car args)))
;     ((not (car args)) code-len)
;     (else (error 'asm-p1-string "Invalid Argument ~s" args))))))