; .EnTete "Le_Lisp version 15.2" " " "Le chargeur me'moire IBM-RT"

; .sp 2
; .SuperTitre "Le Chargeur Me'moire IBM-RT"
; .Auteur "Greg Nuyens"
; .INRIA

; $Revision: 4.2 $
 
; .Centre "****************************************************************"
; .Centre "Ce fichier est en lecture seule hors du projet VLSI de l'INRIA"
; .Centre "****************************************************************"

; Assemble et charge pour un IBM-RT une liste d'instructions LLM3
; en 1 seule passe.  Le code est non-relogeable

(unless (>= (version) 15.2)
        (error 'load 'erricf 'lapibmrt))

(defvar #:sys-package:colon 'ldibmrt)

(add-feature 'loader)

; .Section "Strate'gie de la re'solution des e'tiquettes"

;  1 - les e'tiquettes locales a` une fonction
;  2 - les e'tiquettes locales a` un module
;  3 - les e'tiquettes globales a` tout le syste`me Le_Lisp

; Ce chargeur est capable de produire du code relogeable, ce qui va
; permettre de compacter la zone code.

; .SSection "Les e'tiquettes locales a` une fonction (LOCAL)"

; Une e'tiquette nume'rique est toujours de type LOCAL. Ce trait est
; utilise' par le compilateur pour engendrer des e'tiquettes a` peu de frais.
; Une e'tiquette symbolique locale doit e^tre de'clare'e avant sa premie`re
; utilisation au moyen de la pseudo LOCAL. Cette de'claration permet
; d'e'viter des conflits de noms, mais le compilateur n'utilise jamais
; ce trait.

; Ces e'tiquettes doivent e^tre re'solues a` la fin
; de la liste des instructions ou a` l'apparition de la pseudo ENDL.
; Si elles ne le sont pas, le chargeur de'clenche une erreur.

; .SSection "Les e'tiquettes locales a` un module"

; Les e'tiquettes de ce type, toujours symboliques, ne sont pas de'clare'es.
; Elles sont de'finies au moyen de la pseudo ENTRY.
; Elles peuvent ne pas e^tre re'solues entre deux appels du chargeur mais
; doivent l'e^tre a` l'apparition de la pseudo END.
; Si elles ne le sont pas, le chargeur de'clenche une erreur.
;  Ces e'tiquettes sont dans un des 2 e'tats suivants :
;  1 - elles ne sont pas de'finies : leur nom est dans la A-liste
; :entries-not-resolved qui contient en valeur la liste des adresses
; ou` il faudra charger la ve'ritable adresse quand elle apparaitra.
; Ces de'placements sont sur 16 bits actuellement!
; ?!?!? Que se passe-il avec des modules limite's a` 32k ?!?!?
; ?!?!?     Y a t il beaucoup de gens que cela generait  ?!?!?
;  2 - elles viennent d'apparai^tre (ENTRY). Il n'y a plus qu'un seul
; indicateur :fval qui contient la ve'ritable adresse.
; De plus le symbole est enleve' de :entries-not-resolved et est ajoute'
; dans la liste :entry-list.
;  3 - le END survient, toutes ces e'tiquettes sont de'truites
; de la liste :entry-list, les indicateurs :fval sont de'truits.
; S'il reste des noms dans :entries-not-resolved une erreur est
; de'clenche'e. Rien ne reste donc de propre au chargeur, ces
; e'tiquettes sont des candidats de choix pour le prochain GC.

; .SSection "Les e'tiquettes globales"
; Les e'tiquettes de ce type, toujours symboliques, ne sont utilise'es
; qu'avec les instructions JCALL et JMP.
; Elles sont de'finies au moyen de la pseudo FENTRY qui charge, de`s
; cette de'finition, la FVAL/FTYPE de cette fonction.
; Elles peuvent ne pas e^tre re'solues entre deux appels du chargeur
; qui ne s'en appercoit jamais car il engendre toujours un acce`s
; correspondant a` (FVAL 'symb), ce qui permet en plus de les rede'finir
; et de les recompiler (i.e. si je recharge le module pretty avec pprint
; comme externe, tous les autres modules continueront a` fonctionner
; avec ce nouveau module).
; Les noms des fonctions standard sont des e'tiquettes globales.
 
; .bp
; .Section "Les variables globales du chargeur"
 
; .SSection "Les indicateurs conditionnels du chargeur"

(defvar :31bitfloats (eq 0. 0.)) ; les nbs flottants sur 31 bits
                             ; (utile pour rendre les floats non litteraux)

(defvar #:ld:special-case-loader ())  ; cas spe'cial pour charger le chargeur

(defvar #:ld:shared-strings ())       ; rend les constantes de chai^ne EQ

(defvar :making-fasl? nil)  ; this will be bound to t before the loader is
                            ; called to show that we are constructing a fasl
                            ; file.

; .Section "Les variables globales du chargeur"
 
(defvar :Ecode 
        ; fin de la zone code.
        (subadr (#:system:ecode) 64))
 
(defvar :mem-access
        ; noms symboliques des acce`s indexe's
        '(val     car     cdr     cval    pname
          plist   fval    alink   pkgc    oval    typ))

(defvar :locnil (loc ()))               ; adresse du symbole ()

(defvar :adrBVAR `(adr ,(loc 'sys-package))) ; a modifier si modif dans llinit

(defvar :entry-list ())                 ; liste des points d'entre'e locaux

(defvar :entries-not-resolved ())       ; A-liste des ENTRIES non re'solus

(unless (boundp ':module)               ; Le nom du module en cours de charg.
        (defvar :module ()))

(unless (boundp ':saved-by-loader)      ; liste des litte'raux entre 2 ENDs.
        (defvar :saved-by-loader ()))

(unless (boundp ':global-saved-by-loader) ; liste de vecteurs de litte'raux.
        (defvar :global-saved-by-loader '(     
          ; Ces variables ne sont pas sauve'es par :clean-litt (dynamique).
          #[:lobj :talkp :PCcurrent :llabels :llabels-not-resolved :fntname
            :codop :arg1 :arg2 :arg3 :localstack :valaux :f :nwl obj
            obj1 obj2 obj3])))

; .Section "Les constantes propres au IBM-RT"

(dmd :defvalue (nom val)
     ; de'finition d'une constante IBM-RT
     `(putprop ',nom ,val ':value))

(de :getvalue (nom)
    ; recherche d'une constante IBM-RT
    (cond ((null nom) (:error ':getvalue nom))
          ((fixp nom) nom)
          ((symbolp nom) 
                (let ((val (getprop nom ':value)))
                     (if val (:getvalue val)
                         (:error ':getvalue nom))))
          (t (:error ':getvalue nom))))


; .SSection "Les registres"

(de :register? (obj)
    ; teste si l'argument est un registre IBM-RT   
    (memq obj :registers))

(defvar :registers nil)
(dmd :defregister (reg val)
    ; defines reg to be register number val
    `(progn
       (setq :registers (cons ',reg :registers))
       (:defvalue ,reg ,val)))
				
(:defregister   CCP    0)   ; c constant-pool.
(:defregister   R0     0)   ; register 0
(:defregister   CSP    1)   ; SP C ne pas y toucher
(:defregister   SP     1)   ; SP Lisp 
(:defregister   X1     2)   ; auxiliaire 1 (and c-result register)
(:defregister   CRES   2)
(:defregister   X2     3)   ; auxiliaire 2
(:defregister   X3     4)   ; auxiliaire 3
(:defregister   X4     5)   ; auxiliaire 4
(:defregister   A1     6)   ; 
(:defregister   A2     7)   ;   les fameux 4
(:defregister   A3     8)   ;   accus de LISP
(:defregister   A4     9)   ; 
(:defregister   RBFLOAT 10) ; de'but de la zone des flottants (vide)
(:defregister   RBVECT  10) ; de'but de la zone des vecteurs
(:defregister   RBSTRG  11) ; de'but de la zone des chaines
(:defregister   KNIL    12) ; adresse de NIL (de'but des symboes)
(:defregister   RBSYMB  12) ; adresse du premier symbole (NIL)
(:defregister   NIL     12) ; adresse de NIL (de'but des symboles)
(:defregister   RBCONS  13) ; de'but de zone liste
(:defregister   CP      14) ; Lisp constant pool
(:defregister   LINKR   15) ; link register for lisp

(:defregister   MQ      10) ; system control register Multiply-Quotient


; .SSection "Les constantes d'acce`s"

(:defvalue car 0)
(:defvalue cdr 4)

(:defvalue   cval       0)
(:defvalue   plist      4)
(:defvalue   fval       8)
(:defvalue   pkgc       12)
(:defvalue   oval       16)
(:defvalue   alink      20)
(:defvalue   pname      28)

(:defvalue   val       0)
(:defvalue   typ       4)

; .SSection "Les tests"

(defvar :test1 '((mov a1 a4)))
(defvar :test2 '((mov '1 a1)))
(defvar :fiblap '(
		 (fentry fiblap subr1)
		 (cnbgt a1 '2 100)
		 (mov '1 a1)
		 (return)
	      100
	         (diff '1 a1)
		 (push a1)
		 (call fiblap)
		 (mov a1 a2)
		 (pop a1)
		 (push a2)
		 (diff '1 a1)
		 (call fiblap)
		 (pop a2)
		 (plus a2 a1)
		 (return)))

; .SSection "Les instructions par ordre alpha"

(dmd :definst (opcode mnemonic format)
     ; defines the opcode and format for a mnemonic
     ; see pg A 5 of PC RT assemble for list
     ; see pg 4-26 for format descriptions
     (setq mnemonic (symbol #:sys-package:colon mnemonic))
    `(progn
       (putprop ',mnemonic ',format ':format)
       (:defvalue ,mnemonic ,opcode)))

(de :format (mnemonic)
    ; returns the instruction format for this mnemonic
    (getprop mnemonic ':format))

(:definst #$1	stc	d2)
(:definst #$2	sth	d2)
(:definst #$3	st	d2)
(:definst #$4	lc	d2)
(:definst #$5	lha	d2)
(:definst #$6	cas 	x)
(:definst #$6	lr	x)
(:definst #$6	nop	Ux)
(:definst #$7	l	d2)

(:definst 2184	b	bi) ; 8 bit #$88 + 4 bits (8 + c.s. bit)
(:definst 2185  bge     bi)
(:definst 2186  bne     bi)
(:definst 2187  ble     bi)
(:definst 2188  bcc     bi)
(:definst 2190  bvc     bi)
(:definst 2191  btc     bi)

; the short displacement 
(:definst #$0  b-s	 ji) ; 5 bit #$0 + 3 bits (c.s. bit)
(:definst #$1  bge-s     ji)
(:definst #$2  bne-s     ji)
(:definst #$3  ble-s     ji)
(:definst #$4  bcc-s     ji)
(:definst #$6  bvc-s     ji)
(:definst #$7  btc-s     ji)

(:definst 2281  blt     bi) ; 8 bit #$8e + 4 bits (8 + c.s. bit)
(:definst 2282  beq     bi)
(:definst 2283  bgt     bi)
(:definst 2284  bcs     bi)
(:definst 2286  bvs     bi)
(:definst 2287  bts     bi)

; short immediate
(:definst #$9  blt-s     ji) ; 5 bit #$1 + 3 bits (c.s. bit)
(:definst #$a  beq-s     ji)
(:definst #$b  bgt-s     ji)
(:definst #$c  bcs-s     ji)
(:definst #$e  bvs-s     ji)
(:definst #$f  bts-s     ji)

(:definst #$89	bx	bi)
(:definst #$8a	bala	ba)
(:definst #$8b	balax	ba)
(:definst #$8c	bali	bi)
(:definst #$8df	balix-lr	bi) ; 8 bit #$8d + 4 bit #$f (lr)
(:definst #$8e	b-bit-set	bi)
(:definst #$8f	b-bit-set-x	bi)
(:definst #$90	ais	r)
(:definst #$91	inc	r)
(:definst #$92	sis	r)
(:definst #$93	dec	r)
(:definst #$94	ci-s	r)
(:definst #$95 clrcb	r)
(:definst #$96 	mfs	r)
(:definst #$97	setcb	r)
(:definst #$98	clrb-u	r)
(:definst #$99	clrb-l	r)
(:definst #$9a	setb-u	r)
(:definst #$9b	setb-l	r)
(:definst #$9c	mftbi-u	r)
(:definst #$9d	mftbi-l	r)
(:definst #$9e	mttbi-u	r)
(:definst #$9f	mttbi-l	r)
(:definst #$a0	sari-s	r)
(:definst #$a1	sari-l	r)
(:definst #$a4	lis	r)
(:definst #$a8	sri-s	r)
(:definst #$a9	sri-l	r)
(:definst #$aa	sli-s	r)
(:definst #$ab	sli-l	r)
(:definst #$ac	srpi-s	r)
(:definst #$ad	srpi-l	r)
(:definst #$ae	slpi-s	r)
(:definst #$af	slpi-l	r)
(:definst #$b0	sar	r)
(:definst #$b1	exts	r)
(:definst #$b2  sf	r)
(:definst #$b3	cl	r)
(:definst #$b4	c	r)
(:definst #$b5	mts	r)
(:definst #$b6	d	r)
(:definst #$b8	sr	r)
(:definst #$b9	srp	r)
(:definst #$ba	sl	r)
(:definst #$bb	slp	r)
(:definst #$bc	mftb	r)
(:definst #$bd	tgte	r)
(:definst #$be	tlt	r)
(:definst #$bf	mttb	r)
(:definst #$c0	svc	d)
(:definst #$c1	ai	d)
(:definst #$c2	cal16	d)
(:definst #$c3	oiu	d)
(:definst #$c4	oil	d)
(:definst #$c5	nilz	d)
(:definst #$c6	nilo	d)
(:definst #$c7	xil	d)
(:definst #$c8	cal	d)
(:definst #$c9	lm	d)
(:definst #$ca	lha	d)
(:definst #$cb	ior	d)
(:definst #$cc	ti	d)
(:definst #$cd	l	d)
(:definst #$ce	lc	d)
(:definst #$cf	tsh	d)
(:definst #$d0	lps	d)
(:definst #$d1	aei	d)
(:definst #$d2	sfi	d)
(:definst #$d3	cli	d)
(:definst #$d4	ci	d)
(:definst #$d5	niuz	d)
(:definst #$d6	niuo	d)
(:definst #$d7	xiu	d)
(:definst #$d8	cau	d)
(:definst #$d9	stm	d)
(:definst #$da	lh	d)
(:definst #$db	iow	d)
(:definst #$dc	sth	d)
(:definst #$dd	st	d)
(:definst #$de	stc	d)

(:definst #$e0	abs	r)
(:definst #$e1	a	r)
(:definst #$e2	s	r)
(:definst #$e3	o	r)
(:definst #$e4	twoc	r)
(:definst #$e5	n	r)
(:definst #$e6	m	r)
(:definst #$e7	x	r)
(:definst #$e8	b-r	r)
(:definst #$e9	b-r-x	r)

(:definst #$eb	lh	r)
(:definst #$ec	balr	r)
(:definst #$ed	balrx	r)
(:definst #$ee	b-r	r)
(:definst #$ef	b-asd	r)
(:definst #$f0	wait	r)
(:definst #$f1	ae	r)
(:definst #$f2	se	r)
(:definst #$f3	ca16	r)
(:definst #$f4	onec	r)
(:definst #$f5	clz	r)
(:definst #$f9	mc03	r)
(:definst #$fa	mc13	r)
(:definst #$fb	mc23	r)
(:definst #$fc	mc33	r)
(:definst #$fd	mc30	r)
(:definst #$fe	mc31	r)
(:definst #$ff	mc32	r)

; The addresses of globals in the LLM3 code

(mapc #'(lambda (symbol) (set (symbol #:sys-package:colon symbol)
			       (getglobal symbol)))
      '(ll_rem ll_quo ll_times
	ll_fplus ll_ftimes ll_fdiff ll_fquo
	ll_cfbeq ll_cfbne ll_cfblt ll_cfble ll_cfbgt ll_cfbge))
	
(de :error (f a)
    ; erreur dans la fonction "f" sur l'argument "a"
    (with ((outchan ()))
	  (print "** loader : " f " : " a))
    (error 'loader f a))

; .Section "Interpre'tation d'un objet"
 
(de :ins (obj)
    ; charge un objet (instruction ou pseudo) en me'moire
    (when :talkp
          (if (consp obj) (outpos 4))
          (prin obj)
          (when (>= (outpos) 30) (terpri))
          (outpos 30)
          (:prinhex :PCcurrent)
          (prin "  "))
    (cond
         ((null obj) ())
         ((atom obj)
          ; une e'tiquette locale (symbole ou nb) :
          ; on la rajoute dans :llabels
          (newl :llabels (cons obj (copylist :PCcurrent)))
          ; re'solution des re'fe'rences avants
          (:solve-label obj))
         (t  (setq :codop (car obj)
                   :arg1  (cadr obj)
                   :arg2  (caddr obj)
                   :arg3  (cadddr obj)
                   :localstack 0)
             (selectq :codop
                 ;
                 ; les pseudos-instructions de de'claration
                 ;
                 (ABORT ; Pour re'cupe'rer de la me'moire en cas scraschhhh.
                 )
                 (ENTRY   ; (ENTRY <name> <ftype> <lparam>)
                     ; charge les indicateurs
                     (newl :entry-list
                           (list :arg1
                                 (if (memq :arg2
                                           '(SUBR0 SUBR1 SUBR2 SUBR3
                                                   NSUBR FSUBR MSUBR DMSUBR))
                                     :arg2
                                     (:error "ENTRY" obj))
                                 :arg3))
                     ; re'solution des re'fe'rences avants.
                     (:solventry :arg1)
                     (putprop :arg1 (copylist :PCcurrent) ':fval)
                     (setq :fntname :arg1))
                 (ENDL ; fin d'une fonction locale
                       (when :talkp (terpri))
                       (when :llabels-not-resolved
                             (:error "references locales non resolues"
                              :llabels-not-resolved)))
                 (END  ; fin d'un module
                       ; ve'rification de l'entry-list
                       (:ins '(ENDL))
		       (if :making-fasl?
			   ; dump the fasl to a file
			   (:fasl-write-block))
		       (when :entries-not-resolved
                             (:error "Il reste des ENTRY non resolus "
                              :entries-not-resolved))
                       (while :entry-list
                              (remprop (caar :entry-list) ':fval)
                              (remprop (caar :entry-list) '#:llcp:ftype)
                              (remprop (caar :entry-list) '#:llcp:fval)
                              (remprop (caar :entry-list)
                                  '#:system:loaded-from-file)
                              (nextl :entry-list))
                       (when #:ld:special-case-loader
                             (while
                                   (and (consp #:ld:special-case-loader)
                                        (consp
                                              (car #:ld:special-case-loader)))
                                    (apply 'setfn
                                           (nextl #:ld:special-case-loader))))
                       (:clean-llitt))
                 (EVAL     ; (EVAL s)  e'valuation a` LOAD-TIME
                     (if :making-fasl?
			 (:fasl-emit-eval-block :arg1)
		       (catcherror t (eval :arg1))))
                 (FENTRY   ; (FENTRY <name> <ftype> <lparam>)
                     ; enle`ve les indicateurs (a` ve'rifier ?!?!?)
                     (remprop :arg1 '#:system:loaded-from-file)
                     (setq :valaux :PCcurrent)
                     (cond
		      (#:ld:special-case-loader
		       ; we are bootstrapping the loader, so don't change the
		       ; function cell yet.
                         (newl #:ld:special-case-loader
                               (list :arg1 :arg2 (copylist :valaux))))
		      (:making-fasl?
			; record the fentry with a relative addr
		       (:alignd)
		       (:fasl-record-fentry :arg1 :arg2))
		      (t
		       (remprop :arg1 '#:llcp:ftype)
		       (remprop :arg1 '#:llcp:fval)
		       (setfn :arg1 :arg2 :valaux)))
                     (newl :llabels (cons :arg1 (copylist :PCcurrent)))
                     (setq :fntname :arg1))
                 (LOCAL  ; (LOCAL <name>)
                         ; rend le symbole local a` une fonction.
                         (newl :llabels (ncons :arg1)))
                 (TITLE  ; (TITLE de'finition du nom du module)
                         (setq :module :arg1))
                 ; appel de la partie de'pendante des  machines!
                 ; :machins  contient le ge'ne'rateur d'instructions.
                 (t (:machins obj))))))

(de :machins (obj)
    ; re'alise le chargement de l'instruction obj
    (let ((obj1 (cadr obj)) (obj2 (caddr obj)) (obj3 (cadddr obj)))
         (selectq (car obj)
             (MOV      ; (MOV source dest)
                 (if (:register? obj2)
                     (:movsrc obj1 obj2)
                     (:movdest (:prepsrc obj1 'X1) obj2)))
             (PUSH
                  ; (PUSH <op>)  ==  subi SP 4
                  ; store32 (prepsrc obj1 'X1) SP 0
                  (setq obj1 (:prepsrc obj1 'X1))
                  (:inst ':sis 'SP 4)
		  (:store32disp obj1 'sp 0))
             (JCALL    ; (JCALL <sym>) ==  jsb (FVAL :arg1)
		  (:inst ':sis 'SP 4)
	          (:inst ':balrx 'linkr (:movsrc `(fvalq ,obj1) 'linkr))
		  ; the long form of store is used to make the subject
		  ; instruction be 32 bits
		  (:inst ':st 'linkr 'sp 0))
             (JMP     ; (JUMP <sym>) == (JMP) (FVALQ <sym>)
                 (:movsrc (list 'fvalq obj1) 'X1)
                 (:inst ':balr 'X1 'X1))
             (CAR      
                 ; (CAR A1/A2/A3)  ==  load rx,rx,0
	         (:load32disp obj1 obj1 (:getvalue 'car)))
             (CDR
                 ; (CDR A1/A2/A3)  ==  load rx,rx,CDr
	         (:load32disp obj1 obj1 (:getvalue 'cdr)))	        
             (CABNE    ; (CABNE op1 op2 lab)
                 ; br<>s op1 op2 lab
                 (:cinstbr ':bne obj1 obj2 obj3))
             (RETURN
                    ; (RETURN)  ==  load 'X1 SP 0; addi SP 4; ret X1 X1
	            (:load32disp 'x4 'sp 0)
                    (:inst ':balrx 'linkr 'x4)
                    (:inst ':ais 'SP 4)
		    ; alignment is not enough.  There must be a 32 bit
		    ; subject instruction
		    (:nop))
             (BRA
                 ; (BRA <lab>)  ==  br lab
                 (:instbr ':b obj1))
             (BTNIL    ; (BTNIL op lab)
                 (:btf1xx 'KNIL ':beq))
             (CABEQ    ; (CABEQ op1 op2 lab)
                 ; br=s op1 op2 lab
                 (:cinstbr ':beq obj1 obj2 obj3))
             (POP
                 ; (POP <op>)  == load obj1 SP 0; addi SP 4
                 (cond ((:register? obj1)
                        (:load32disp obj1 'SP 0)
                        (:inst ':ais 'SP 4))
                       (t
                         (:load32disp 'X1 'SP 0) 
                         (:inst ':ais 'SP 4)
                         (:movdest 'X1 obj1))))
             (BFNIL    ; (BFNIL op lab)
                 (:btf1xx 'KNIL ':bne))
             (BTCONS   ; (BTCONS op lab)
                 (:btf1xx 'RBCONS ':bge))
             (BFCONS   ; (BFCONS op lab)
                 (:btf1xx 'RBCONS ':blt))
             ;
             ; les tests de type
             ;
             (BTFIX   ; (BTNUMB op lab)
                 (:bt2xx ''0 'RBFLOAT)) ; \\ why ''0?
             (BFFIX   ; (BFNUMB op lab)
                 (:bf2xx ''0 'RBFLOAT))
             (BTFLOAT  ; (BTFLOAT op1 lab)
                 (:btf1xx ''0 ':blt))
             (BFFLOAT  ; (BFFLOAT op1 lab)
                 (:btf1xx ''0 ':bge))
             (BTSTRG   ; (BTSTRG op1 lab)
                 (:bt2xx 'RBSTRG 'RBSYMB))
             (BFSTRG   ; (BFSTRG op1 lab)
                 (:bf2xx 'RBSTRG 'RBSYMB))
             (BTVECT   ; (BTVECT op1 lab)
                 (:bt2xx 'RBVECT 'RBSTRG))
             (BFVECT   ; (BFVECT op1 lab)
                 (:bf2xx 'RBVECT 'RBSTRG))
             (BTSYMB   ; (BTSYMB op1 lab)
                 (:bt2xx 'RBSYMB 'RBCONS))
             (BFSYMB   ; (BFSYMB op1 lab)
                 (:bf2xx 'RBSYMB 'RBCONS))
             (BTVAR    ; (BTVAR op1 lab)
                 (:bt2xx :adrBVAR 'RBCONS))
             (BFVAR    ; (BFVAR op1 lab)
                 (:bf2xx :adrBVAR 'RBCONS))
             ;
             ;  Les comparaisons entieres
             ;
             (CNBEQ    ; (CNBEQ op1 op2 lab)
                 (:cnbxxieqn ':beq))
             (CNBNE    ; (CNBNE op1 op2 lab)
                 (:cnbxxieqn ':bne))
             (CNBLT    ; (CNBLT op1 op2 lab)
                 (:cnbxx ':blt))
             (CNBLE    ; (CNBLE op1 op2 lab)
                 (:cnbxx ':ble))
             (CNBGT    ; (CNBGT op1 op2 lab)
                 (:cnbxx ':bgt))
             (CNBGE    ; (CNBGE op1 op2 lab)
                 (:cnbxx ':bge))
             ;
             ;  Les comparaisons arithme'tiques flottantes.
             ;
             (CFBEQ    ; (CFBEQ op1 op2 lab)
                 (:comp2float ':ll_cfbeq))
             (CFBNE    ; (CFBNE op1 op2 lab)
                 (:comp2float ':ll_cfbne))
             (CFBLT    ; (CFBLT op1 op2 lab)
                 (:comp2float ':ll_cfblt))
             (CFBLE    ; (CFBLE op1 op2 lab)
                 (:comp2float ':ll_cfble))
             (CFBGT    ; (CFBGT op1 op2 lab)
                 (:comp2float ':ll_cfbgt))
             (CFBGE    ; (CFBGE op1 op2 lab)
                 (:comp2float ':ll_cfbge))
             ; 
             ; Les instructions arithme'tiques
             ;
             (DECR     ; (DECR op)
                 (:macaro1op ':sis 1))
             (DIFF      ; (DIFF op1 op2)
                 (:macaro2op ':s))
             (INCR     ; (INCR op)
                 (:macaro1op ':ais 1))
             (LAND   ; (LAND op1 op2)
                     (:logop-2op ':n ':nilz))
             (LOR    ; (LOR op1 op2) 
                     (:logop-2op ':o ':oil))
             (LXOR   ; (LXOR op1 op2)
                     (:logop-2op ':x ':xil))
             (LSHIFT ; (LSHIFT circ op)
		     (:lshift obj1 obj2))
             (NEGATE    ; (NEGATE op) 
                 (setq obj2 obj1)
                 (:macaro2op ':twoc))
             (PLUS      ; (PLUS op1 op2)
                 (:macaro2op ':a))
             (REM
                 (:c-arith-2op ':ll_rem))
             (QUO
                 (:c-arith-2op ':ll_quo))
             (TIMES
                 (:c-arith-2op ':ll_times))
             ;
             ;  Les instructions arithme'tiques flottantes
             ;
             (FPLUS  (:instr2float ':ll_fplus))
             (FDIFF  (:instr2float ':ll_fdiff))
             (FTIMES (:instr2float ':ll_ftimes))
             (FQUO   (:instr2float ':ll_fquo))
             ;
             ;  Les autres instructions (par ordre alpha)
             ;
             (ADJSTK   ; (ADJSTK 'nb)
                 (if (:immediat? obj1)
                     (cond ((and (ge (cadr obj1) 0) (lt (cadr obj1) 4))
                            (:inst ':ais 'SP (mul 4 (cadr obj1))))
                           ((and (le (cadr obj1) 0) (gt (cadr obj1) -4))
                            (:inst ':sis 'SP (mul 4 (sub 0 (cadr obj1)))))
                           (t
                            (:laddr32disp 'sp 'sp (mul 4 (cadr obj1)))))
                     (:movsrc obj1 'X1)
                     (:inst ':sli-s 'X1 2)
                     (:inst ':exts 'X1 'X1)
                     (:inst ':a 'SP 'X1)))
             (BRI
                 (:inst ':balr 'X1 (:prepsrc obj1 'X1)))
             (BRX ; (BRX (l1 ... ln) index)
	          (:movsrc obj2 'x1)
                  (:inst ':sli-s 'X1 2)
		  (:alignd) ; so that the addresses are on fullword boundary
                  (:laddr32loc 'X2 (:aa (logshift
		  			   (:size (:cal16
		  				:cau
						:a :l :balr))
					 1)
			              :PCcurrent)) ; result is not PC 
		  (:inst ':a 'x1 'x2)   ; add the offset (now in bytes)
		  (:inst ':l 'x1 'x1 0)
                  (:inst ':balr 'X1 'X1)
                  (while obj1
                         (:val32abs (:contig-val-reference 
			 		(cadr (nextl obj1))))))
             (CALL
                  ; (CALL <sym>)
                  (:inst ':sis 'SP 4)
                  (:inst ':balix-lr (:rshiftadr (:valrel obj1)))
		  (:inst ':st 'linkr 'sp 0))
             (HBMOVX   ; (HPMOVX val string index)
                 (cond ((:small-pos? obj3)
                        ; index constant
                        (:load32disp 'X2 (:prepsrc obj2 'X2) 0) ; pointer into heap
                        (:inst ':stc 
			    (:prepsrc obj1 'X1)
			    'x2
			    (add 8 (cadr obj3))))
                       (t ; index calcule'
                          (:movaheabix obj2 obj3 'X2)
                          (:inst ':stc (:prepsrc obj1 'X1) 'X2 0))))
             (HBXMOV  ; (HBXMOV string index dest) string[index] -> dest
                 (:movaheabix obj1 obj2 'X2)
                 (if (:register? obj3)
                     (:inst ':lc obj3 'X2 0)
                     (:inst ':lc 'X1 'X2 0)
                     (:movdest 'X1 obj3)))
             (HGSIZE   ; (HGSIZE vector/string arg2)
                 (:load32disp 'X1 (:prepsrc obj1 'X1) 0)
                 (if (:register? obj2)
                     (:load32disp obj2 'X1 '4)
                     (:load32disp 'X2 'X1 '4)
                     (:movdest 'X2 obj2)))
             (HPMOVX   ; (HPMOVX val vector index)
                 (:movaheap obj2 obj3 'X2)
                 (:store32disp (:prepsrc obj1 'X1) 'X2 0))
             (HPXMOV   ; (HPXMOV vector index val)
                 (:movaheap obj1 obj2 'X2)
                 (if (:register? obj3)
                     (:load32disp obj3 'X2 0)
                     (progn (:load32disp 'X1 'X2 0)
                            (:movdest 'X1 obj3))))
             (MOVXSP   ; (MOVXSP val depl)
                 ; on ajoute le de'placement au haut de pile
		 ; \\ should optimize immediate?
                 (:movsrc obj2 'X2)
                 (:inst ':sli-s 'X2 2)
                 (:inst ':a 'X2 'SP)
                 (:store32disp (:prepsrc obj1 'X1) 'X2 0))
             (NOP
                 (:nop))
             (SOBGEZ   ; (SOBGEZ op lab)
                 (let ((r1 (:prepsrc obj1 'X1)))
                      (:inst ':exts r1 r1)
                      (:inst ':sis r1 1)
                      (unless (eq r1 obj1)
                              (:movdest r1 obj1))
		      (:inst ':ci-s r1 0)
                      (:instbr ':bge obj2)
                      (:convnb r1)
                      (unless (eq r1 obj1)
                              (:movdest r1 obj1))))
             (SSTACK   ; (SSTACK <op>) movl op,sp
                 (:movsrc obj1 'SP))
             (STACK
                 (:movdest 'SP obj1))
             (XSPMOV   ; (XSPMOV depl val)
                 (:movsrc obj1 'X1)
                 (:inst ':sli-s 'X1 2)
                 (:inst ':a 'X1 'SP)
                 (if (:register? obj2)
                     (:load32disp obj2 'X1 0)
                     (:load32disp 'x2 'X1 0)
                     (:movdest 'X2 obj2)))
             (t ; c'est donc une erreur
                (:error ':machins obj1)))))

; .Section "Auxiliaires de chargement d'instructions" 


(de :ll-call (adr)
    ; do a jcall.  (call uses balix-r)
    ; adr must be on a word boundary.
    ; adr must be the linkr already loaded with the address.
    (:assert (eq adr 'linkr) ':ll-call)
    (:inst ':sis 'SP 4)
    (:inst ':balrx 'linkr 'linkr) ; \\ this may not work if lr gets stepped on.
                           ; in which case the calls will have to change
                           ; where they prepare the target.
    (:store32disp 'linkr 'sp 0)
    (:alignd))

; .Section "Auxiliaires de chargement"

(de :immediat? (val)
    (and (consp val)
         (eq (car val) 'quote)
         (fixp (cadr val))
         (neqn (cadr val) #$8000)))

;(de :16-bit-immediate? (val)
;    (and (fixp val) (neqn val #$8000)))

(de 4-bit-value? (val)
    (and (fixp val)
	 (neqn val #$8000)
	 (ge val 0)
	 (lt val 16)))

(de :small-pos? (val)
    ; teste si l'argument est un nb positif sur 15 bits
    (and (consp val)
         (eq (car val) 'quote)
         (fixp (cadr val))
         (neqn (cadr val) #$8000)
         (ge (cadr val) 0)))

(de :small-pos-value? (n)
    ; tests if n is a 15 bit fixp
    (and
         (fixp n)
         (neqn n #$8000)
         (ge n 0)))

(de :small-imm? (val)
    ; teste si l'argument est une petite valeur imme'diate (4 bits)
    (and (:small-pos? val)
         (lt (cadr val) 16)))

(de :small-neg-imm? (val)
    ; teste si l'argument est une petite valeur imme'diate (4 bits unsigned)
    (and (consp val)
         (eq (car val) 'quote)
	 (fixp (cadr val))
	 (le (cadr val) 0)
         (gt (cadr val) -32)))

(de :nop ()
          (:inst ':cas 'R0 'R0 'R0))

(de :alignd ()
    ; inserts noops to align
    (when (neqn 0 (logand 3 (or (fixp :PCcurrent) (cdr :PCcurrent))))
          (:nop)))


;(de :PCalignd (pc)
;    ; simply adds to the PC to align
;    (if (neqn 0 (logand 3 (or (fixp :PCcurrent) (cdr :PCcurrent))))
;        (addadr pc 2)
;        pc))

(de :movaheabix (op ind reg)
    ; charge l'adresse heap d'octet "op+ind" dans "reg"
    (:load32disp reg (:prepsrc op reg) 0)
    (if (:small-pos? ind)
        (:laddr32disp reg reg (add 8 (cadr ind)))
        (:inst ':ais reg 8)
        (:inst ':a reg (:prepsrc ind 'X1))))

(de :c-arith-2op (ll-target)
    ; prepares the arguments, then calls the llm3 routine ll-target (which is
    ; a loc) and puts the result in the right place.
    (:movsrc obj1 'x2) ; opposite order of course
    (:inst ':exts 'x2 'x2)
    (:movsrc obj2 'x1)
    (:inst ':exts 'x1 'x1)
    (:laddr32loc 'linkr (symeval ll-target))
    (:ll-call 'linkr)
    (:movdestnb 'cres obj2))

(de :instr2float (instr)
    ; call an llm3 floating point entry (which will call c)
    (:unrolfloat obj1 :accusingle1)
    (:unrolfloat obj2 :accusingle2)
    (:laddr32loc 'linkr (symeval instr))
    (:ll-call 'linkr)
    (:rolfloat :accusingle2 obj2))

;; the addresses of the pseudo accumulators used for floating point.
(defvar :accusingle1 (getglobal "_accusingle1"))
(defvar :accusingle2 (getglobal "_accusingle2"))

(de :unrolfloat (src flt-accu)
    ;; decode a 31 bit float into the pseudo-accumulator.
    (let ((reg (:movsrc src 'x1)))
	  (:inst ':sli-s reg 1)
	  (:store32loc reg flt-accu 'x2)))

(de :rolfloat (flt-acc dest)
    ;;encodes an IEEE float in the pseudo
    ;; accu dest. and produces a Le-Lisp 31 bit float 
    (let ((reg (:load32loc 'x1 flt-acc)))
      (:inst ':sri-s reg 1)
      (:inst ':setb-u reg 0)
      (:movdest reg dest)))

(de :comp2float (cond)
    ;; assemble a comparison (cond) between two floats
    (:unrolfloat obj1 :accusingle1)
    (:unrolfloat obj2 :accusingle2)
    (:laddr32loc 'linkr (symeval cond))
    (:ll-call 'linkr)
    (:inst ':ci-s 'CRES 0)
    (:instbr ':bne obj3))

(de :cnbxx (cond)
    ; comparaison arithme'tique sur 16 bits signe's
    ; on suppose que s'il y a une constante c'est en 2e`me ope'rande.
    (:inst ':exts 'X1 (:prepsrc obj1 'X1))
    (cond ((:small-imm? obj2)
           ; petit entier sur 4 bits
	   (:inst ':ci-s 'x1 (cadr obj2))
           (:instbr cond obj3))
          ((:small-pos? obj2)
           ; pas la peine d'e'tendre le signe de la constante 15 bits
	   (:inst ':c 'x1 (:prepsrc obj2 'x2))
           (:instbr cond obj3))
          (t ; cas le plus long
           (:inst ':exts 'X2 (:prepsrc obj2 'X2))
	   (:inst ':c 'x1 'x2)
           (:instbr cond obj3))))

(de :cnbxxieqn (cond)
    ; comparaison arithme'tique sur 32 bits si = ou /=
   (cond ((:small-imm? obj1)
	  (:inst ':ci-s (:prepsrc obj2 'x2) (cadr obj1))
	  (:instbr cond obj3))
	 ((:small-pos? obj1)
	  (:inst ':ci 0 (:prepsrc obj2 'x2) (cadr obj1))
	  (:instbr cond obj3))
	 ((:small-imm? obj2)
	  (:inst ':ci-s (:prepsrc obj1 'x2) (cadr obj2))
	  (:instbr cond obj3))
	 ((:small-pos? obj2)
	  (:inst ':ci 0 (:prepsrc obj1 'x2) (cadr obj2))
	  (:instbr cond obj3))
         (t
            (:cinstbr cond obj1 obj2 obj3))))

(de :btf1xx (borne cond)
    (:cinstbr cond obj1 borne obj2))

(de :bf2xx (btype etype)
    (unless (:register? etype) (:error ':bf2xx etype))
    (setq obj1 (:prepsrc obj1 'X1))
    (:inst ':c obj1 (:prepsrc btype 'x2))
    (:instbr ':blt obj2)
    (:inst ':c obj1 (:prepsrc etype 'x2))
    (:instbr ':bge obj2))
    
(de :bt2xx (btype etype)
    (unless (:register? etype) (:error ':bt2xx etype))
    (setq obj1 (:prepsrc obj1 'X1))
    (:inst ':c obj1 (:prepsrc btype 'x2))
    (:instbr-s ':blt-s (:size (:c :lr :blt)))
    (:inst ':c obj1 (:prepsrc etype 'x2))
    (:instbr ':blt obj2))

(dmd :size (instr-list)
    ; returns the size in half-words (16 bits) of the instruction list
    (let ((size 0))
      (mapc #'(lambda (inst)
		(setq size
		      (add size
			   (selectq (:format inst)
				    ((ji x d2 r) 1)
				    ((bi ba d) 2)
				    (t (:error ':size inst))))))
	    instr-list)
      size))

    ; .Section "Les fonctions de chargement des ope'randes"

(de :prepsrc (arg reg)
    ; pre'pare l'argument source "arg"
    ; s'il le faut range l'argument dans l'auxiliaire "reg"
    ; retourne le nume'ro de registre qui contient l'argument
    (cond ((eq arg 'nil)
           ; ope'rande nil (en fait ||)
           'KNIL)
          ((:register? arg)
           ; c'est de'ja` un registre
           arg)
          ((atom arg)
           ; c'est un mot me'moire.
           (cond ((memq arg '(LLINK DLINK ITCOUNT))
		  (if (not :making-fasl?)		      
		      (:load32loc reg (symeval (symbol 'llcp arg)))
		      ; we must do a general 32 bit load at fasloadtime
		      (:fasl-record-eval-literal-reference
		          reg `(vag ,(symbol 'llcp arg)))
		      (:load32disp reg reg 0))
                  reg)
                 ((memq arg '(CBINDN TAG LOCK PROT))
		  ; \\ why does the previous one load memory while
		  ; this one only loads the address?
		  (if (not :making-fasl?)
		      (:laddr32loc reg (symeval (symbol 'llcp arg)))
		      ;  load reg with symbol at fasloadtime
		      (:fasl-record-eval-literal-reference
		          reg `(vag ,(symbol 'llcp arg))))
                  reg)
                 (t
		  ; \\ What does this mess do?
                   ; ne doit jamais arriver pour le compilo
                   ; sauf en cas de nouvelles de'finitions.
                   (if (and (symbolp arg) 
                            (getfn1 'ld-dir arg))
                       (funcall (getfn1 'ld-dir arg) arg)
                       (:error ':prepsrc arg)))))
          ((memq (car arg) :mem-access)
           ; acce`s a` la me'moire indirect par registre
	   ; \\ Presumes that (cadr arg) is a register
	   (:load32disp reg (cadr arg) (:getvalue (car arg)))
           reg)
          (t
            (selectq (car arg)
                (QUOTE
                      ; constante Lisp
                      (cond
		       ((or (fixp (cadr arg)) (floatp (cadr arg)))
			    ; an immediate.  For both memory and fasl,
			    ; just load it as binary
			    (:laddr32 reg (cadr arg)))
		       (:making-fasl?
			    ; remember the literal reference
			    (:fasl-record-literal-reference reg (cadr arg)))
		       (t
			     ; c'est un litte'ral a` sauver
    			     (ifn (stringp (cadr arg))
				  (:add-llitt (cadr arg))
				  (:add-llitts arg))
			     (:laddr32 reg (cadr arg))))
                      reg)
                (CVALQ
                      ; adresse d'une CVAL de symbole
		      (:assert (symbolp (cadr arg)) :prepsrc)
		      (if :making-fasl?
			  (progn
			    (:fasl-record-literal-reference reg (cadr arg))
			    (:load32disp reg reg (:getvalue 'CVAL)))
			   (:load32abs reg (cadr arg))
			   (:add-llitt (cadr arg)))
                      reg)
                (FVALQ
                      ; adresse d'une FVAL de symbole
                      (:assert (symbolp (cadr arg)) :prepsrc)
		      (if :making-fasl?
			  (progn
			    (:fasl-record-literal-reference reg (cadr arg))
			    (:load32disp reg reg (:getvalue 'fval)))
			   (:laddr32 reg (cadr arg)) ; load the atom adr
                           (:load32disp reg reg (:getvalue 'fval)) ; indirect
			      ; through fn cell
                           (:add-llitt (cadr arg)))
                      reg)
                (|&|
                 (:load32disp reg 'SP (mul 4 (cadr arg)))
                 reg)
                ((|@| adr)
		 (:laddr32loc reg (:val-reference (cadr arg)))
                 reg)
                (eval
                     ; Pour calculer des ope'randes a` load time.
		 (if :making-fasl?
		     (:error "eval not implemented in fasl" ':prepsrc)
		   (:prepsrc (eval (cadr arg)) reg)))
                (t (:error ':prepsrc arg))))))))

(de :movsrc (arg regin)
    ; transporte l'ope'rande "arg" de n'importe quel type
    ; dans le registre de nom "regin".
    ; retourne toujours "regin" en valeur.
    (setq arg (:prepsrc arg regin))
    (unless (eq arg regin) (:inst ':lr regin arg 0))
    regin)
                  
(de :movdest (src dest)
    ; transporte "src" (toujours registre) vers "dest"
    (cond ((:register? dest)
           ; reg -> reg
           (:inst ':lr dest src 0))
          ((atom dest)
           (:assert (memq dest '(LLINK DLINK ITCOUNT)) ':movdest)
	   (if :making-fasl?
	       (progn
		 (:fasl-record-eval-literal-reference
		    'x4
		    `(vag ,(symbol 'llcp dest)))
		 (:store32disp src 'x4 0))
                (:store32loc src (symeval (symbol 'llcp dest)) 'x4)))
          ((memq (car dest) :mem-access)
           ; reg -> mem
           (:store32disp src (cadr dest) (:getvalue (car dest))))
          ((eq (car dest) 'cvalq)
           ; reg -> CVAL symbole
           (:assert (symbolp (cadr dest)) :movdest)
	   (if :making-fasl?
	       (progn
		 (:fasl-record-literal-reference 'x4 (cadr dest))
		 (:store32disp src 'x4 (:getvalue 'CVAL)))
                (:store32abs src (cadr dest) 'x4)
                (:add-llitt (cadr dest))))
          ((eq (car dest) '|&|)
           (:store32disp src 'SP (mul 4 (cadr dest))))
          ((eq (car dest) 'eval)
           ; Pour calculer des ope'randes a` load time.
           (if :making-fasl?
	       (:error "no eval in movdest" ':movdest)
	     (:movdest src (eval (cadr dest)))))
          (t (:error ':movdest dest))))

(de :movdestnb (reg arg)
    ; range la valeur nume'rique dans "reg"
    ; dans l'ope'rande "arg"
    (cond ((:register? arg)
	   (:inst ':nilz arg reg '#$ffff))
          (t ; cas le plus long
           (:movdest (:convnb reg) arg))))

; .Section "Les fonctions auxiliares de ge'ne'ration"

(de :macaheap (op reg)
    ; charge dans "reg" l'adresse heap de op
    (:inst ':l reg (:prepsrc op reg) 0)
    (:inst ':ais reg 8))

;(de :movaheab (op ind reg)
;    ; charge l'adresse heap d'octet op+ind dans reg
;    (:macaheap op reg)
;    (:inst ':a reg (:prepsrc ind 'X1)))

(de :movaheap (op ind reg)
    ; charge l'adresse heap de mot op+ind dans reg
    (:macaheap op reg)
    (:movsrc ind 'X1)
    (:inst ':sli-s 'X1 2)
    (:inst ':a reg 'X1))

(de :convnb (reg)
    ; repasse en format 16 bits
    (:inst ':nilz reg reg #$ffff)
    reg)

(de :macaro1op (op 2nd)
    (:movsrc obj1 'X1)
    (:inst op 'X1 2nd)
    (:convnb 'X1)
    (:movdest 'X1 obj1))

(de :macaro2op (op)
    (:inst ':exts 'X1 (:prepsrc obj2 'X1))
    (:inst ':exts 'X2 (:prepsrc obj1 'X2))
    (:inst op 'X1 'X2)
    (:convnb 'X1)
    (:movdest 'X1 obj2))

(de :lshift (obj1 obj2)
    (cond ((:small-imm? obj1)
	   ; small positive, do a sli
	   (:lshift-aux obj2 ':sli-s ':sli-l (cadr obj1)))
	  ((:small-neg-imm? obj1)
	   (:lshift-aux obj2 ':sri-s ':sri-l (- (cadr obj1))))
	  (t
	   ; otherwise the full blown dynamic sign test
	   (:inst ':exts 'X2 (:prepsrc obj1 'X2))
	   (let ((reg (:prepsrc obj2 'X1)))
	     (:inst ':ci-s 'X2 0)
	     (:instbr-s ':bge-s (:size (:bge-s :twoc :sr :b-s)))
	     (:inst ':twoc 'X2 'X2)
	     (:inst ':sr reg 'X2)
	     (:instbr-s ':b-s (:size (:b-s :sl)))
	     (:inst ':sl reg 'X2)
	     (:movdestnb reg obj2)))))
    
(de :lshift-aux (obj2 op-s op-l value)
    (let ((reg (:prepsrc obj2 'x1)))
		    (if (> value 15)
			(:inst op-l reg (- value 16))
			(:inst op-s reg value))
		    (:movdestnb reg obj2)))
	
(de :logop-aux (reg op immediate-op)
    ; fonction auxiliaire de ge'ne'ration des
    ; instructions logiques : "reg" contient
    ; le 2e`me ope'rande pre^t, "op" est l'ope'rateur
    ; a` appliquer, obj1 est le premier ope'rande.
    (cond ((:immediat? obj1)
           ; entier sur 15 bits (car propagation de signe)
           (:inst immediate-op reg reg (cadr obj1)))
          (t ; le cas le plus de'favorable
           (:inst op reg (:prepsrc obj1 'x2)))))

(de :logop-2op (op immediate-op)
    ; decides whether to assemble the immediate or full version of a
    ; logical operator.
    (cond ((:register? obj2)
	   (:logop-aux obj2 op immediate-op)) 
          (t  (:prepsrc obj2 'X1)
              (:logop-aux 'X1 op immediate-op)
              (:movdestnb 'X1 obj2))))


; .Section "Les fonctions auxiliaires de chargement me'moire"

(de :cinstbr (code op1 op2 adr)
    ; generates the compare and the branch
    ; used for places that can't benefit by compare immediate.
    (:inst ':c (:prepsrc op1 'X1) (:prepsrc op2 'X2))
    (:instbr code adr))

(de :instbr (code adr)
    ; calculates the pc rel displacement to adr
    (let ((offset-in-words (:rshiftadr (:valrel adr))))
        (:inst code offset-in-words)))

;(de :cinstbr-s (code op1 op2 displacement)
;    ; generates the compare and the branch
;    ; used for places that can't benefit by compare immediate.
;    (:inst ':c (:prepsrc op1 'X1) (:prepsrc op2 'X2))
;    (:instbr-s code adr))

(de :instbr-s (code displacement)
    ; for immediate branches.  Takes displacement in half-words
        (:inst code displacement)))

(de :debug (onoff)
     (if onoff
	(de :inst (code . args)
	    ; test version
	;    (print)
	    (prin code "	")
	    (mapc (lambda (arg) (prin arg ",")) args)
	    (print))))
	
(de :inst &nobind
    (selectq (:format (arg 0))
	     (ji (:inst-ji (arg 0) (arg 1)))
	     (x  (:inst-x (arg 0) (arg 1) (arg 2) (arg 3)))
	     (d2
	      (:inst-d2 (arg 0) (arg 1) (arg 2) (arg 3)))
	     (r  (:inst-r (arg 0) (arg 1) (arg 2)))
	     (bi (:inst-bi (arg 0) (arg 1)))
	     (ba (:inst-ba (arg 0) (arg 1)))
	     (d  (:inst-d (arg 0) (arg 1) (arg 2) (arg 3)))
	     (t  (:error "unknown format or instruction in :inst : "
			 (arg 0)))))


;(:debug nil)

(dmd :inst-ji (op ji)
     ; load a jump immediate format instruction.
    `(:1word (logor (logshift (:getvalue ,op) 8)
		    ,ji)))

(dmd :inst-x (op r1 r2 r3)
     ; load a x (3 register) format instruction.
    `(:1word (logor
	      (logor (logshift (:getvalue ,op) 12)
		     (logshift (:getvalue ,r1) 8))
	      (logor (logshift (:getvalue ,r2) 4)
		     (:getvalue ,r3)))))

(dmd :inst-d2 (op d2 r1 r2)
     ; load a d2 (2 register + 4 bit disp) format instruction.
    `(:1word (logor
	      (logor (logshift (:getvalue ,op) 12)
		     (logshift ,d2 8))
	      (logor (logshift (:getvalue ,r1) 4)
		     (:getvalue ,r2)))))

(dmd :inst-r (op r1 r2)
     ; load an r (2 register) format instruction.
    `(:1word (logor
	      (logshift (:getvalue ,op) 8)
	      (logor (logshift (:getvalue ,r1) 4)
		     (:getvalue ,r2)))))
    

(dmd :inst-bi (op-ie bi)
     ; load an bi (20 bit pc-rel branch) format instruction.
     (:assert (consp bi) ':inst-bi)
    `(progn
       (:1word (logor
		(logshift (:getvalue ,op-ie) 4)
		(logand (car ,bi) #$f))) ; bottom 4 bits of high-order word
                                        ; of bi.
       (:1word (cdr ,bi))))

(dmd :inst-ba (op ui)
     ; absolute inst makes no sense in lap
     `(:error ':inst-ba ,op))
    
(dmd :inst-d (op r1 r2 d2)
     ; load a d format instruction (16 bit disp and 2 registers)
     `(progn
	(:1word (logor
		 (logshift (:getvalue ,op) 8)
		 (logor
		  (logshift (:getvalue ,r1) 4)
		  (:getvalue ,r2))))
	(:1word ,d2)))

;(de :val16abs (obj)
;    ; chargement d'une valeur absolue de 16 bits
;    (:1word obj))

(de :val32abs (obj)
    ; chargement d'une valeur absolue de 32 bits
    (cond ((fixp obj)
           (:1word 0)
           (:1word obj))
          ((consp obj)
            (:1word (car obj))
            (:1word (cdr obj)))
          (t (:error ':val32abs obj))))

(de :load32abs (reg obj)
    ; generates the instructions to load a long from a 32 bit memory address
	     ; since d2 is sign-extended in l, must do a cal (and cau) then l
    (cond ((fixp obj)
;	   (if (:small-pos-value? obj)
;	     (:inst ':l reg 'r0 obj)
	     (:inst ':cal16 reg 'r0 obj)
	     (:inst ':l reg reg 0)
	     reg)
;	  )
	  (t (:load32loc reg (loc obj)))))

(de :load32loc (reg obj)
    ;; generates the instructions to load a 32 bit immediate in loc form.
    ;; When we are making fasl, we cannot optimize by knowing the
    ;; address we are loading because
    ;; when we reload this code (fasload time), the address will be different.
    ;; This can change the size of the code, which will screw up the relative
    ;; branches we don't want to recalculate.
    (if (and (:small-pos-value? (cdr obj)) (not :making-fasl?))
	(progn
	  (:inst ':cau reg 'r0 (car obj))
	  (:inst ':l reg reg (cdr obj)))
      (:inst ':cal16 reg 'r0 (cdr obj))
      (:inst ':cau reg reg (car obj))
      (:inst ':l reg reg 0))
    reg)

(de :laddr32disp (destreg sourcereg disp)
    ; load destreg with sourcereg+disp (sign extended)
    (:inst ':cal destreg sourcereg disp)
       destreg)
    
(de :laddr32 (reg obj)
    ; generates the instructions to load a 32 bit immediate
    (cond ((fixp obj)
	   (cond ((4-bit-value? obj)
	   	      (:inst ':lis reg obj))
		 (t 		      	   
		   (:inst ':cal16 reg 'r0 (logand obj #$ffff)))))
	  (t
		(:laddr32loc reg (loc obj))))
    reg)

(de :laddr32loc (reg loc)
	   (:inst ':cal16 reg 'r0 (cdr loc)) ; load the lower
	   (:inst ':cau reg reg (car loc))
	   reg)


(de :load32disp (reg accu disp)
    ; generates the instructions to load a 32 bit absolute value from memory
    (:assert (:register? accu) :load32disp)
    (:inst ':l reg accu disp)
    reg)

(de :store32abs (reg obj via)
    ; reg is stored at obj 
    (cond ((fixp obj)
;	   (if (:small-pos-value? obj)
;	     (:inst ':st reg 'r0 obj)
	     (:inst ':st reg obj 0))
;	  )
	  (t (:store32loc reg (loc obj) via))))))

(de :store32loc (source-reg loc via)
   ; store reg at the address specified by loc
;   (if (:small-pos-value? (cdr loc))
;       (progn
;	     (:inst ':cau via 'r0 (car loc)) ; load the upper
;	     (:inst ':st source-reg via (cdr loc)))
       (:inst ':cal16 via 'r0 (cdr loc))
       (:inst ':cau via via (car loc))
       (:inst ':st source-reg via 0)))))
       
(de :store32disp (reg accu disp)
    ; generates the instructions to load a 32 bit absolute value from memory
    (:assert (:register? accu) :store32disp)
    (:inst ':st reg accu disp))

(dmd :assert (form where)
     `(ifn ,form (:error ',where ',form)))

(de :1word (obj)
    ; chargement d'un mot de 16 bits en me'moire a` l'adresse
    ; contenue dans :PCcurrent, et gestion de cette valeur.
    (when :talkp
          ; impression du code en hexade'cimal.
          (when (> :nwl 6)
                (setq :nwl 0)
                (terpri)
                (outpos 30)
                (:prinhex :PCcurrent)
                (prin "  "))
          (incr :nwl)
          (prin " ")
          (:prinhex obj))
    (if (gtadr :PCcurrent :Ecode)
        (with ((outchan ()))
              (print ERRFCOD)
              (exit #:system:toplevel-tag))
        (memory :PCcurrent obj)
	(setq :PCcurrent (incradr :PCcurrent 2))))        

;(de :patch32rel ()
;    (let ((PCprevious (:sa :PCcurrent 2)))
;

;(de :val16rel (adr)
;    ; charge un de'placement sur 16 bits (en fait toujours sur 32 bits!)
;    (let ((l (:aa (:valrel adr) 2)))
;         (:patch32rel) ; rajoute le bit rel 32 dans le mot pre'ce'dent
;         (:1word (car l))
;         (:1word (cdr l))))

; .Section "Fonctions de calcul d'adresse"

; .SSection "Les adresses absolues sur 32 bits"


(de :valadr (adr)
    ; calcule la valeur d'une adresse, locale a` un module, de type :
    ; symbole, numb ou constante de type (nh . nl)
    ; retourne une adresse (h . l) ou bien () si non de'finie
    (cond
       ((atom adr)
          ; e'tiquette symbolique ou nume'rique
          (cond ((cassq adr :llabels)
                   ; e'tiquette locale re'solue
                   )
                ((and (symbolp adr) (getprop  adr ':fval))
                   ; les fonctions ENTRY de'ja` charge'es (avant END!)
                   )
                (t ; sinon non de'finie
                   ())))
       (t ; les constantes adresses de type (h . l)
          (if (and (fixp (car adr)) (fixp (cdr adr)))
              adr
              (:error "VALADR" adr)))))

; The unresolved address must have high order bits so that it is not optimized
; to a short anywhere
(defvar :unresolved-address '(#$f0f0 . #$f0f0))

(de :val-reference (adr)
    ; retourne une addresse 32 bits absolue ou :unresolved-address
    (if :making-fasl?
	;; since this is an absolute reference it must emit a fixup 
	;; for fasl read time.
	(:fasl-record-pair-absolute-reference :pccurrent))
    (let ((valadr (:valadr adr)))
         (if valadr
	     valadr
             (if (and (symbolp adr) (null (assq adr :llabels)))
                 (:addentry ':solve-abs adr (copy :PCcurrent))
                 (:addlabel ':solve-abs adr (copy :PCcurrent)))
             :unresolved-address)))

(de :contig-val-reference (adr)
    ; returns a 32 bit absolute reference which will be stored 
    (if :making-fasl?
	(:fasl-record-absolute-reference :pccurrent))
    (let ((valadr (:valadr adr)))
         (if valadr
	     valadr
             (if (and (symbolp adr) (null (assq adr :llabels)))
                 (:addentry ':solve-contig-abs adr (copy :PCcurrent))
                 (:addlabel ':solve-contig-abs adr (copy :PCcurrent)))
             :unresolved-address)))

(de :valrel (adr)
    ; retourne un de'placement par rapport a` PC ou :unresolved-address
    (let ((valadr (:valadr adr)))
         (if valadr
             (:sa valadr :PCcurrent)
             (if (and (symbolp adr) (null (assq adr :llabels)))
                 (:addentry ':solve-20rel adr (copy :PCcurrent))
                 (:addlabel ':solve-20rel adr (copy :PCcurrent)))
             :unresolved-address)))

(de :rshiftadr (adr)
    (cond ((fixp adr) (logshift adr -1))
    	  ((evenp (car adr))
		(rplacd adr (logshift (cdr adr) -1))
		(rplaca adr (logshift (car adr) -1)))
	  (t (rplacd adr (logor #$8000 (logshift (cdr adr) -1)))
		(rplaca adr (logshift (car adr) -1)))))


(de :solve-20rel (ref)
    ; installs the 20 bit offset in a bi format instruction
    (let ((relval
                 (:rshiftadr (:sa :PCcurrent ref))))
         (memory ref (logor
		      (logand (memory ref) #$fff0)
			(logand (car relval) #$f)))
         (memory (addadr ref 2) (cdr relval))))

(de :solve-abs (ref)
; installs the 32 bit address in a cal, cau pair.
         (memory (addadr ref 2) (cdr :PCcurrent))
         (memory (addadr ref 6) (car :PCcurrent)))

(de :solve-contig-abs (ref)
; installs the 32 bit address in 32 contiguous bits
         (memory ref (car :PCcurrent))
         (memory (addadr ref 2) (cdr :PCcurrent)))

(de :solve-label (obj)
;called when a label appears.  Look in :llabels-not-resolved (the unresolved references).
; For each pair found for obj in :llabels-not-resolved, we call the appropriate
; function to resolve the absolute or relative use of the label.
    (mapc #':apply-solve-fn
          (cassq obj :llabels-not-resolved))
    (setq :llabels-not-resolved
          (delete (assq obj :llabels-not-resolved) :llabels-not-resolved)))

(de :solventry (obj)
    (mapc #':apply-solve-fn
          (cassq obj :entries-not-resolved))
    (setq :entries-not-resolved
          (delete (assq obj :entries-not-resolved) :entries-not-resolved)))

(de :apply-solve-fn (fn-adr)
; calls the appropriate solve-fn on the address 
	 (selectq (car fn-adr)
	 	(:solve-abs (:solve-abs (cdr fn-adr)))
		(:solve-20rel
			(:solve-20rel (cdr fn-adr)))
		(:solve-contig-abs
			(:solve-contig-abs (cdr fn-adr))))))
(de :aa (a1 a2)
    (setq #:ex:regret 0)
    (xcons (ex+ 
              (if (consp a1) (cdr a1) a1)
              (if (consp a2) (cdr a2) a2))
           (ex+ 
              (if (consp a1) (car a1) 0)
              (if (consp a2) (car a2) 0))))

(de :sa (a1 a2)
    (:aa (:aa a1 1)
     (cons (if (consp a2) (ex- (car a2)) -1)
           (if (consp a2) (ex- (cdr a2)) (ex- a2)))))

; .Section "Gestion des tables"
 
(de :addlabel (solvefn sym adr)
    ; rajoute le symbole <sym> (a l'adresse <adr>)
    ; dans la table des e'tiquettes locales
    (let ((val (assq sym :llabels-not-resolved)))
         (if val
             (rplacd val (cons (cons solvefn adr) (cdr val)))
             (newl :llabels-not-resolved (list sym (cons solvefn adr))))))
 
(de :addentry (solvefn sym adr)
    ; rajoute le symbole <sym> (a l'adresse <adr>)
    ; dans la table des entre'es locales a` etre resoulu par solvefn
    (let ((val (assq sym :entries-not-resolved)))
         (if val
             (rplacd val (cons (cons solvefn adr) (cdr val)))
             (newl :entries-not-resolved (list sym (cons solvefn adr))))))
 
(de  :clean-llitt ()
     ; nettoie et sauve la table des litte'raux :saved-by-loader
     ; dans :global-saved-by-loader sous forme d'un vecteur si
     ; si il n'y a pas eu de TITLE dans :module sinon.
     ; ne doit e^tre fait qu'au END.
     (let ((l :saved-by-loader)
           (i -1)
           v)
          (while l
                 (if (and (symbolp (car l))
                          (or (boundp (car l))
                              (typefn (car l))))
                     (setq :saved-by-loader 
                           (delq (nextl l) :saved-by-loader))
                    (nextl l)))
         (when (gt (length :saved-by-loader) 0)
                  (setq v (makevector (length :saved-by-loader) ()))
                  (while :saved-by-loader
                         (vset v (setq i (add i 1)) (nextl :saved-by-loader)))
                  (if :module
                      (putprop :module v ':saved-by-loader)
                      (newl :global-saved-by-loader v)))
         (setq :module ()) ))

(de :add-llitt (obj)
    ; rajoute un litte'ral a` la table des litte'raux :saved-by-loader
    (cond ((memq obj :saved-by-loader))
          (t (newl :saved-by-loader obj))))

(de :add-llitts (obj)
    ; rajoute une chai^ne de caracte`res a` la table des litte'raux
    ; en essayant de partager les chai^nes.
    ; ?!?!?! Cette ide'e d'Ascander est toujours en discussion ?!?!?
    (let ((s (and #:ld:shared-strings (member (cadr obj) :saved-by-loader))))
         (ifn s
              (newl :saved-by-loader (cadr obj))
              (rplaca (cdr obj) (car s)))))

; .Section "Sorties et Dumps Hexade'cimal"

(de :prinhex (n)
    ; imprime sur 4 ou 8 chiffres hexa le nb ou l'adresse n
    (cond ((fixp n)
           (:prinhexb (logand (logshift n -8) #$FF))
           (:prinhexb (logand n #$FF)))
          ((consp n)
	    (prin "0x")
           (:prinhex (car n)) (prin " ")
           (:prinhex (cdr n)))
          (t (:error ':prinhex n))))
 
(de :prinhexb (n)
    ; imprime sur 2 chiffres hexa le nb n
    (cond ((not (fixp n)) (:error ':prinhexb n))
          ((< n 0) (setq n 255))
          ((< n 16) (princn #/0)))          
    (with ((obase 16)) (prin n)))

(de :mem (fn . n)
    (:memory-dump (loc (valfn fn)) (or (car n) 9)) fn)

(de :memory-dump (adr n)
    ; dump la memoire en hexa de <adr> sur <n> mots
    (setq adr (copy adr))       ;  pour le incradr
    (until (<= n 0)
           (:prinhex adr)
           (outpos 15)
           (repeat 8 (:prinhex (memory adr))
                     (prin " ")
                     (incradr adr 2)
                     (decr n))
           (terpri)))
 
; .Section "Chargement des points d'entree speciaux du lap/llcp"

; .Section "Fonctions principales de chargement"
 
(de loaderesolve () (loader '((end))))

(de loader
 (:lobj . :talkp)
    ; <:lobj> est la liste des objets a` charger
    ; <:talkp> = T si on de'sire un listage hexa du chargement
    (when (consp :talkp)                ; l'argument est optionnel!
          (setq :talkp (car :talkp)))
    (let ((:PCcurrent (#:system:ccode)) ; le compteur ordinal courant
          (:llabels)                    ; A-liste des e'tiquettes locales
          (:llabels-not-resolved)       ; A-L. des e'tiq. loc. non re'solues
          (:fntname 'loader)            ; fonction en cours de chargement
          :codop                        ; variable globale de travail
          :arg1                         ;    itou
          :arg2                         ;    itou
          :arg3                         ;    itou
          :localstack                   ;    ?!?!?!?!?!?
          :valaux                       ;    itou pour des valeurs locales.
          :f                            ;    itou (pour des getfn1)
          (:nwl 0)                      ;    itou pour tabler le code produit.
          (#:ex:regret))                ; pour rester propre
         ; le re'cupe'rateur d'erreur syste`me
;         (catcherror t
             ; le re'cupe'rateur des erreurs du chargeur
             (tag :tagerr
                  ; #:system:ccode ne sera actualise' 
                  ; que si tout se passe bien sans erreur
                  (while :lobj
                         (setq :nwl 0)
                         (when (gtadr :PCcurrent :Ecode)
                               (with ((outchan ()))
                                     (print ERRFCOD)
                                     (exit #:system:toplevel-tag)))
                         (:ins (nextl :lobj))
                         (when :talkp (terpri)))
                  ; test des re'fe'rences non re'solues 
                  (:ins '(ENDL))
		  ; actualise le nouveau de'but de la zone code
		  (#:system:ccode :PCcurrent)))
;	     )
         ()))
 
; .Section "Bootstrap"

(when (neq (typefn '#:llcp:nlist) 'subr0)
      ; Les fonctions internes du compilateur
      (loader '(
            (fentry #:llcp:nlist subr0)
            (pop a3)
            (mov nil a1)
            (bra 4)
         3  (pop a2)
            (jcall xcons)
         4  (sobgez a4 3)
            (bri a3)

            (fentry #:llcp:errwna subr2)    ; A1 <- fnt; A2 <- bad-nb-arg
            (mov a2 a3)
            (mov 'errwna a2)
            (jmp error)
            (end) )
         () ))

(unless (or (eq (typefn 'loaderesolve) 'expr) (get 'loaderesolve 'resetfn))
    (mapc
         (lambda (m)
                 (when (typefn m)
                       (remfn m)
                       (remprop m '#:system:loaded-from-file)))
         (oblist '#.#:sys-package:colon)))

;-----------------------------------------------------------------------------
;
; \\ verify:
; 
; check ecode in read-code-block
; talkp in lap-to-fasl
; that stdio has been uploaded from opera
; * does negate sign extend twice?