; .EnTete "Le_Lisp version 15.2" " " "Le chargeur me'moire NS 32032"
; .sp 2 
; .SuperTitre "Le Chargeur Me'moire NS"
; .Auteur "Francis Dupont"
; .INRIA
; $Header: lapns.ll,v 4.1 88/01/13 12:21:03 kuczynsk Rel $

; Assemble et charge pour un NS 32032 une liste d'instructions LLM3
; en 1 seule passe et avec du code relogeable.

(unless (= (version) 15.2)
	(error 'load 'erricf 'lapns))

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

(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.

; Toute re'fe'rence a` ce type d'e'tiquette engendre un de'placement
; par rapport au PC (de 8 ou de 16 bits).
; 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` 8k ?!?!?
; ?!?!?     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 :stopcopy (typefn '#:ld:gcafter-daemon)) ; pour le Stop & Copy

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

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

; .SSection "Les autres variables globales"
 
; adresse du de'but des flottants
(unless (boundp ':bfloat)
        (defvar :bfloat (getglobal "bfloat")))

; adresse du de'but des vecteurs
(unless (boundp ':bvect)
	(defvar :bvect  (getglobal "bvect")))

; adresse du de'but des chai^nes
(unless (boundp ':bstrg)
	(defvar :bstrg  (getglobal "bstrg")))

; adresse du de'but des variables
(unless (boundp ':bvar)
	(defvar :bvar   (getglobal "bvar")))

(defvar :Ecode				; fin de la zone code.
	(subadr (#:system:ecode) 64))

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

(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-nr :fntname
	    :codop :arg1 :arg2 :arg3 :valaux :f :nwl obj])))

(unless (boundp '#:ld:cons-llitt) (defvar #:ld:cons-llitt ()))

(unless (boundp ':local-cons-llitt) (defvar :local-cons-llitt ()))

; .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 (relatives)
	    (mapc (lambda (l)
		     (selectq (car l)
			 (8    ; c'est une r.n.r. relative sur 8 bits
			       (:1byterelPC (cdr l)))
			 (16   ; c'est une r.n.r. relative sur 16 bits
			       (:1wordrelPC (cdr l)))
			 (32   ; c'est une r.n.r relative sur 32 bits
			       (:1doublerelPC (cdr l)))
			 (0    ; c'est une r.n.r absolue sur 32 bits
			       (:1doublePC (cdr l)))
			 (t    ; c'est pour un BRX
			       (:1wordrel (car l) (cdr l)))))
		  (cassq obj :llabels-nr))
	    (setq :llabels-nr
		  (delete (assq obj :llabels-nr) :llabels-nr)))
       (t  (setq :codop (car obj)
		 :arg1  (cadr obj)
		 :arg2  (caddr obj)
		 :arg3  (cadddr obj))
	   (selectq :codop
	    ;
	    ; les pseudos-instructions  (par ordre alphabe'tique)
	    ;
	    (ABORT)  ; Pour re'cupe'rer de la me'moire en cas scraschhhh.
	    (ENTRY   ; (ENTRY <name> <ftype> <lparam>)
		(:align)
		; 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.
		(mapc (lambda (l)
			(selectq (car l)
			    (16 ; c'est une r.n.r. relative sur 16 bits
				(:1wordrelPC (cdr l)))
			    (32 ; c'est une r.n.r. relative sur 32 bits
				(:1doublerelPC (cdr l)))
			    (0  ; c'est une r.n.r. absolue sur 32 bits
				(:1doublePC (cdr l)))
			    (t  ; c'est pour un BRX
			        (:1wordrel (car l) (cdr l)))))
		       (cassq :arg1 :entries-not-resolved))
		(setq :entries-not-resolved
		      (delete (assq :arg1 :entries-not-resolved)
			      :entries-not-resolved))
		(putprop :arg1 (copylist :PCcurrent) ':fval)
		(setq :fntname :arg1))
	    (ENDL ; fin d'une fonction locale
	       (when :talkp (terpri))
	       (when :llabels-nr
		     (:error "Il reste des references locales non resolues "
			     :llabels-nr)))
	    (END  ; fin d'un module
		  ; ve'rification de l'entry-list
	       (:ins '(ENDL))
	       (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)))
			    (if (and :stopcopy (typefn ':patch-cons-llitt))
				(:patch-cons-llitt))
                            (remprop (caar #:ld:special-case-loader)
                               ':fval )
                            (remprop (caar #:ld:special-case-loader)
                               '#:llcp:ftype )
                            (remprop (caar #:ld:special-case-loader)
                               '#:llcp:fval )
                            (remprop (caar #:ld:special-case-loader)
                               '#:system:loaded-from-file )
			    (apply 'setfn (nextl #:ld:special-case-loader))))
	       (:clean-llitt))
	    (EVAL     ; (EVAL s)  e'valuation a` LOAD-TIME
		(catcherror t (eval :arg1)))
	    (FENTRY   ; (FENTRY <name> <ftype> <lparam>)
		(:align)
		; enle`ve les indicateurs (a` ve'rifier ?!?!?)
		(remprop :arg1 '#:system:loaded-from-file)
		(setq :valaux :PCcurrent)
		(if #:ld:special-case-loader
		    (newl #:ld:special-case-loader
			  (list :arg1 :arg2 (copylist :valaux)))
		    (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))))))

(de :machins ()
    ; re'alise le chargement de l'instruction <obj>. Fonctionne dans
    ; le me^me environnement que la fonction pre'ce'dente : obj :codop .....
    (selectq :codop
      ;
      ;  A tout seigneur tout honneur : l'instruction la plus utilise'e
      ;
      (MOV      ; (MOV source dest)
	 (cond ((and (consp :arg1) (eq (car :arg1) '@))
		(:opnsn #$27 #$A8)		; addr src,r0 / movd r0,dst
		(:opns-pos-depl :arg1)
		(:opns-dst #$17 #$00 :arg2))
	       ((and (consp :arg1)
		     (eq (car :arg1) 'QUOTE)
		     (cadr :arg1)
		     (symbolp (cadr :arg1)))
		(:opnsn #$27 #$68)		; addr n(r5),r0 / movd r0,dst
		(:opnsquotesymb (cadr :arg1))
		(:opns-dst #$17 #$00 :arg2))
	      (t 
		(:opns-src-dst #$17 #$00 :arg1 :arg2)))) ; movd src,dst
      ;
      ; Les instructions de contro^le
      ;
      (BRA      ; (BRA <lab>)  ==  br lab
	 (:opns-branch #$EA :arg1))
      (BRI      ; (BRI <op>) == movd op,r0 / jump 0(r0)
	 (:1byte #$17)
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$7F #$42 #$00))
      (BRX      ; (BRX (<lab1> <lab2> ... <labn>) <index>)
	 (unless (:register :arg2)
		 (:1byte #$17)		; movd index,r0
		 (:opns-src #$00 :arg2 ()))
	 (let ((pc (copylist :PCcurrent)))
	     (:opnsn #$7D #$EF)		; casew *+4[r0:w]
	     (:1byte (selectq :arg2
			  (A1 #$D9) (A2 #$DA) (A3 #$DB) (A4 #$DC) (t #$D8)))
	     (:1byte #$04)
	     (mapc ':opns-brx (cirlist pc) :arg1)))
      (CALL     ; (CALL etiq) == bsr etiq
	 (:opns-branch #$02 :arg1))
      (JCALL    ; (JCALL <sym>) ==  jsr (FVAL :arg1)
	 (:opnsfvalq :codop :arg1))		; jsr 0(n(r5))
      (JMP      ; (JMP <sym>) == jump (FVAL <sym>)
	 (:opnsfvalq :codop :arg1))		; jump 0(n(r5))
      (RETURN   ; (RETURN) == ret 0
	 (:opnsn #$12 #$00))
      (SOBGEZ   ; (SOBGEZ op lab)  addqw -1,op / cmpqw 0,op / ble lab
	 (:1byte #$8D)
	 (:opns-src #$07 :arg1 ())
	 (:1byte #$1D)
	 (:opns-src #$00 :arg1 ())
	 (:opns-branch #$7A :arg2))
      ;
      ; les instructions sur la pile de donne'e
      ;
      (POP      ; (POP <op>)  == movd tos,op
	 (ifn (and (consp :arg1) (eq (car :arg1) '&))
	      (:opns-dst #$17 #$B8 :arg1)
	      ; le cas vicieux du (pop (& <n>))
	      (:opnsn #$57 #$BE)
	      (:opns-depl (mul 4 (add1 (cadr :arg1))))))
      (PUSH     ; (PUSH <op>)
	 (cond ((and (consp :arg1) (eq (car :arg1) '@))
		(:opnsn #$E7 #$AD)		; addr src,tos
		(:opns-pos-depl :arg1))
	       ((and (consp :arg1)
		     (eq (car :arg1) 'QUOTE)
		     (cadr :arg1)
		     (symbolp (cadr :arg1)))
		(:opnsn #$E7 #$6D)			; addr n(r5),tos
		(:opnsquotesymb (cadr :arg1)))
	      (t 
		(:1byte #$D7)			; movd src,tos
		(:opns-src #$05 :arg1 ()))))
      (SSTACK   ; (SSTACK <op>) lprd sp,op
	 (:1byte #$EF)
	 (:opns-src #$04 :arg1 ()))
      (STACK    ; (STACK <op>) == sprd sp,op
	 (:1byte #$AF)
	 (:opns-src #$04 :arg1 ()))
      (XSPMOV   ; (XSPMOV depl val)
	 (cond ((:fixp :arg1)
		(:opnsn #$17 #$C8)		; movd n(sp),r0
		(:opns-pos-depl (mul 4 (cadr :arg1))))
	       (t
		(:1byte #$17)			; movd depl,r0
		(:opns-src #$00 :arg1 ())
		(:opnsn #$17 #$F0 #$C8 #$00)))	; movd 0(sp)[r0:d],r0
	 (:opns-dst #$17 #$00 :arg2))		; movd r0,val
      ;
      ; les tests de type
      ;
      (BTNIL    ; (BTNIL op lab) == cmpd op,r5 / beq lab
	 (:1byte #$47)
	 (:opns-src #$01 :arg1 ())
	 (:opns-branch #$0A :arg2))
      (BFNIL    ; (BFNIL op lab) == cmpd op,r5 / bne lab
	 (:1byte #$47)
	 (:opns-src #$01 :arg1 ())
	 (:opns-branch #$1A :arg2))
      (BTCONS   ; (BTCONS op lab) == cmpd op,r6 / bge lab
	 (:1byte #$87)
	 (:opns-src #$01 :arg1 ())
	 (:opns-branch #$DA :arg2))
      (BFCONS   ; (BFCONS op lab) == cmpd op,r6 / blt lab
	 (:1byte #$87)
	 (:opns-src #$01 :arg1 ())
	 (:opns-branch #$CA :arg2))
      (BTFIX    ; (BTFIX op1 lab) == movd op,r0 / cmpd bfloat,r0 / bhi lab
	 (:1byte #$17)
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$07 #$A8)
	 (:opns-pos-depl :bfloat)
	 (:opns-branch #$4A :arg2))
      (BFFIX    ; (BFFIX op1 lab) == movd op,r0 / cmpd bfloat,r0 / bls lab
	 (:1byte #$17)
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$07 #$A8)
	 (:opns-pos-depl :bfloat)
	 (:opns-branch #$5A :arg2))
      (BTFLOAT  ; (BTFLOAT op1 lab)
	 (ifn :31bitfloats
	      (:brt2 :bfloat :bvect)
	      (:1byte #$1F)			; cmpqd 0,op1
	      (:opns-src #$00 :arg1 ())
	      (:opns-branch #$6A :arg2)))	; bgt lab
      (BFFLOAT  ; (BFFLOAT op1 lab)
	 (ifn :31bitfloats
	      (:brf2 :bfloat :bvect)
	      (:1byte #$1F)			; cmpqd 0,op1
	      (:opns-src #$00 :arg1 ())
	      (:opns-branch #$7A :arg2)))	; ble lab
      (BTSTRG   ; (BTSTRG op1 lab)
	 (:1byte #$17)			; movd op,r0
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$07 #$A8)		; cmpd bstrg,r0
	 (:opns-pos-depl :bstrg)
	 (:1byte #$4A)			; bhi end
	 (let ((pc (copy :PCcurrent)))
	     (:1byte #$00)		; sera resolu a la fin
	     (:opnsn #$47 #$01)		; cmpd r0,r5
	     (:opns-branch #$AA :arg2)	; blo lab
	     (memory pc (add1 (subadr :PCcurrent pc)))))
      (BFSTRG   ; (BFSTRG op1 lab)
	 (:1byte #$17)			; movd op,r0
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$07 #$A8)		; cmpd bstrg,r0
	 (:opns-pos-depl :bstrg)
	 (:opns-branch #$4A :arg2)	; bhi lab
	 (:opnsn #$47 #$01)		; cmpd r0,r5
	 (:opns-branch #$BA :arg2))	; bhs lab
      (BTVECT   ; (BTVECT op1 lab)
	 (:brt2 :bvect :bstrg))
      (BFVECT   ; (BFVECT op1 lab)
	 (:brf2 :bvect :bstrg))
      (BTSYMB   ; (BTSYMB op1 lab)
	 (:1byte #$17)			; movd op,r0
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$47 #$01)		; cmpd r0,r5
	 (:1byte #$AA)			; blo end
	 (let ((pc (copy :PCcurrent)))
	     (:1byte #$00)		; sera resolu a la fin
	     (:opnsn #$87 #$01)		; cmpd r0,r6
	     (:opns-branch #$AA :arg2)	; blo lab
	     (memory pc (add1 (subadr :PCcurrent pc)))))
      (BFSYMB   ; (BFSYMB op1 lab)
	 (:1byte #$17)			; movd op,r0
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$47 #$01)		; cmpd r0,r5
	 (:opns-branch #$AA :arg2)	; blo lab
	 (:opnsn #$87 #$01)		; cmpd r0,r6
	 (:opns-branch #$BA :arg2))	; bhs lab
      (BTVAR    ; (BTVAR op1 lab)
	 (:1byte #$17)			; movd op,r0
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$07 #$A8)		; cmpd bvar,r0
	 (:opns-pos-depl :bvar)
	 (:1byte #$4A)			; bhi end
	 (let ((pc (copy :PCcurrent)))
	     (:1byte #$00)		; sera resolu a la fin
	     (:opnsn #$87 #$01)		; cmpd op,r6
	     (:opns-branch #$AA :arg2)	; blo lab
	     (memory pc (add1 (subadr :PCcurrent pc)))))
      (BFVAR    ; (BFVAR op1 lab)
	 (:1byte #$17)			; movd op,r0
	 (:opns-src #$00 :arg1 ())
	 (:opnsn #$07 #$A8)		; cmpd bvar,r0
	 (:opns-pos-depl :bvar)
	 (:opns-branch #$4A :arg2)	; bhi lab
	 (:opnsn #$87 #$01)		; cmpd r0,r6
	 (:opns-branch #$BA :arg2))	; bhs lab
      (CABEQ    ; (CABEQ op1 op2 lab) == cmpd op1,op2 / beq lab
	 (:opns-src-dst #$07 #$00 :arg1 :arg2)
	 (:opns-branch #$0A :arg3))
      (CABNE    ; (CABNE op1 op2 lab) == cmpd op1,op2 / bne lab
	 (:opns-src-dst #$07 #$00 :arg1 :arg2)
	 (:opns-branch #$1A :arg3))
      ;
      ;  Les autres instructions (par ordre alpha)
      ;
      (ADJSTK   ; (ADJSTK 'nb)
	 (if (:fixp :arg1)
	     (cond ((eq (cadr :arg1) 0))
		   ((and (ge (cadr :arg1) -32) (lt (cadr :arg1) 32))
		    (:opnsn #$7C #$A5)		; adjspb n
		    (:1byte (sub 0 (mul 4 (cadr :arg1)))))
		   (t (:opnsn #$7D #$A5)	; adjspw n
		      (:1word (sub 0 (mul 4 (cadr :arg1))))))
	     (:opnsn #$CE #$1D)			; movxwd nb,r0
	     (:opns-src #$00 :arg1 ())
	     (:opnsn #$4E #$23 #$00)		; negd r0,r0
	     (:opnsn #$4E #$17 #$A0 #$02)	; lshd 2,r0
	     (:opnsn #$7F #$05)))		; adjspd r0
      (CAR	; (CAR A1/A2/A3/A4)  ==  MOV 0(Ax),Ax	?!?!? obsolete
	 (:ins `(MOV (CAR ,:arg1) ,:arg1)))
      (CDR	; (CDR A1/A2/A3/A4)  ==  MOV 4(Ax),Ax	?!?!? obsolete
	 (:ins `(MOV (CDR ,:arg1) ,:arg1)))
      (HBMOVX   ; (HBMOVX val string index)   val -> string[index]
	 (:adrheap-r7 :arg2)			; r7 <- adr heap de arg2
	 (cond ((:fixp :arg3)
		(:1byte #$17)			; movd val,r0
		(:opns-src #$00 :arg1 ())
		(:opnsn #$D4 #$03)		; movb r0,n(r7)
		(:opns-pos-depl (cadr :arg3)))
	       (t (:opnsn #$17)			; movd depl,r0
		  (:opns-src #$00 :arg3 ())
		  (:1byte #$14)			; movb val,0(r7)[r0:b]
		  (:opns-src #$07 :arg1 #$78)
		  (:1byte #$00))))
      (HBXMOV   ; (HBXMOV string index dest) string[index] -> dest
	 (:adrheap-r7 :arg1)			; r7 <- adr heap de arg2
	 (cond ((:fixp :arg2)
		(:opnsn #$14 #$78)		; movb n(r7),r0
		(:opns-pos-depl (cadr :arg2)))
	       (t (:1byte #$17)			; movd index,r0
		  (:opns-src #$00 :arg2 ())
		  (:opnsn #$14 #$E0 #$78 #$00))) ; movb 0(r7)[r0:b],r0
	 (:1byte #$CE)
	 (:opns-dst #$18 #$00 :arg3))		; movzbd r0,dest
      (HGSIZE   ; (HGSIZE vector/string arg2)
	 (:adrind-r0 :arg1)			; r0 <- adr ind de arg1
	 (:opnsn #$17 #$40 #$04)		; movd 4(r0),r0
	 (:opns-dst #$17 #$00 :arg2))		; movd r0,dst
      (HPMOVX   ; (HPMOVX val vector index)
	 (:adrheap-r7 :arg2)			; r7 <- adr heap de arg2
	 (cond ((:fixp :arg3)
		(:1byte #$17)			; movd val,r0
		(:opns-src #$00 :arg1 ())
		(:opnsn #$D7 #$03)		; movd r0,n(r7)
		(:opns-pos-depl (mul 4 (cadr :arg3))))
	       (t (:1byte #$17)			; movd depl,r0
		  (:opns-src #$00 :arg3 ())
		  (:1byte #$97)			; movd val,0(r7)[r0:d]
		  (:opns-src #$07 :arg1 #$78)
		  (:1byte #$00))))
      (HPXMOV   ; (HPXMOV vector index val)
	 (:adrheap-r7 :arg1)			; r7 <- adr heap de arg2
	 (cond ((:fixp :arg2)
		(:opnsn #$17 #$78)		; movd n(r7),r0
		(:opns-pos-depl (mul 4 (cadr :arg2))))
	       (t (:1byte #$17)			; movd index,r0
		  (:opns-src #$00 :arg2 ())
		  (:opnsn #$17 #$F0 #$78 #$00))) ; movd 0(r7)[r0:d],r0
	 (:opns-dst #$17 #$00 :arg3))		; movd r0,val
      (MOVXSP   ; (MOVXSP val depl)
	 (:1byte #$D7)				; movd val,r7
	 (:opns-src #$01 :arg1 ())
	 (cond ((:fixp :arg2)
		(:opnsn #$57 #$3E)		; movd r7,n(sp)
		(:opns-pos-depl (mul 4 (cadr :arg2))))
	       (t (:1byte #$17)			; movd depl,r0
		  (:opns-src #$00 :arg2 ())
		  (:opnsn #$97 #$3F #$C8 #$00)))) ;  movd r7,0(sp)[r0:d]
      (NOP    ; (NOP) ne fait rien mais perd du temps et de la place
	 (:1byte #$A2))
      (XTOPST   ; (XTOPST :arg1) echange du sommet de pile avec :arg1
	 (:opnsn #$17 #$B8)			; movd tos,r0
	 (:1byte #$D7)				; movd arg,tos
	 (:opns-src #$05 :arg1 ())
	 (:opns-dst #$17 #$00 :arg1))		; movd r0,arg
      ;
      ;  Les comparaisons arithme'tiques entieres. cmpw op1 op2 / bnxx lab
      ;
      (CNBEQ    ; (CNBEQ op1 op2 lab)
	 (:cnbxx #$0A))
      (CNBNE    ; (CNBNE op1 op2 lab)
	 (:cnbxx #$1A))
      (CNBLT    ; (CNBLT op1 op2 lab)
	 (:cnbxx #$CA))
      (CNBLE    ; (CNBLE op1 op2 lab)
	 (:cnbxx #$7A))
      (CNBGT    ; (CNBGT op1 op2 lab)
	 (:cnbxx #$6A))
      (CNBGE    ; (CNBGE op1 op2 lab)
	 (:cnbxx #$DA))
      ;
      ;  Les comparaisons arithme'tiques flottantes.
      ;
      (CFBEQ    ; (CFBEQ op1 op2 lab)
	 (if :31bitfloats
	     (:generatecall2subr '#:llcp:feqn :arg3)
	     (:cfbxx #$0A)))
      (CFBNE    ; (CFBNE op1 op2 lab)
	 (if :31bitfloats
	     (:generatecall2subr '#:llcp:fneqn :arg3)
	     (:cfbxx #$1A)))
      (CFBLT    ; (CFBLT op1 op2 lab)
	 (if :31bitfloats
	     (:generatecall2subr '#:llcp:flt :arg3)
	     (:cfbxx #$CA)))
      (CFBLE    ; (CFBLE op1 op2 lab)
	 (if :31bitfloats
	     (:generatecall2subr '#:llcp:fle :arg3)
	     (:cfbxx #$7A)))
      (CFBGT    ; (CFBGT op1 op2 lab)
	 (if :31bitfloats
	     (:generatecall2subr '#:llcp:fgt :arg3)
	     (:cfbxx #$6A)))
      (CFBGE    ; (CFBGE op1 op2 lab)
	 (if :31bitfloats
	     (:generatecall2subr '#:llcp:fge :arg3)
	     (:cfbxx #$DA)))
      ;
      ;  Les instructions arithme'tiques (par ordre alpha)
      ;
      (DECR     ; (DECR op)  ==  addqw -1,op
	 (:1byte #$8D)
	 (:opns-src #$07 :arg1 ()))
      (DIFF      ; (DIFF op1 op2)  ==  subw op1 op2 ; op2 - op1 -> op2
	 (:opns-arith #$21 #$00 :arg1 :arg2))
      (INCR     ; (INCR op)  ==  addqw 1,op
	 (:1byte #$8D)
	 (:opns-src #$00 :arg1 ()))
      (LAND   ; (LAND op1 op2)  ==  andw op1,op2
	 (:opns-arith #$29 #$00 :arg1 :arg2))
      (LOR    ; (LOR op1 op2)  ==  orw op1 op2
	 (:opns-arith #$19 #$00 :arg1 :arg2))
      (LXOR   ; (LXOR op1 op2)  ==  xorw op1 op2
	 (:opns-arith #$39 #$00 :arg1 :arg2))
      (LSHIFT ; (LSHIFT circ op) == lshw circ,op
	 (:1byte #$4E)
	 (ifn (:fixp :arg1)
	      (:opns-arith #$15 #$00 :arg1 :arg2)
	      (ifn (:register :arg2)
		   (:error "LSHIFT" :arg2))
	      (:opns-dst #$15 #$A0 :arg2)
	      (:1byte (logand #$FF (cadr :arg1)))))
      (NEGATE    ; (NEGATE op)  ==  negw  op,op
	 (:1byte #$4E)
	 (:opns-arith #$21 #$00 :arg1 :arg1))
      (PLUS      ; (PLUS op1 op2)  ==  addw op1 op2
	 (:opns-arith #$01 #$00 :arg1 :arg2))
      (REM       ; (REM op1 op2)  ==  modw op1,op2
	 (:1byte #$CE)
	 (:opns-arith #$35 #$00 :arg1 :arg2))
      (QUO       ; (QUO op1 op2)  ==  divw op1 op2
	 (:1byte #$CE)
	 (:opns-arith #$31 #$00 :arg1 :arg2))
      (TIMES     ; (TIMES op1 op2)  ==  mulw op1 op2
	 (:1byte #$CE)
	 (:opns-arith #$21 #$00 :arg1 :arg2))
      ;
      ;  Les instructions arithme'tiques flottantes
      ;
      (FPLUS  (:macflotop '#:llcp:fadd))    ; 
      (FDIFF  (:macflotop '#:llcp:fsub))    ; 
      (FTIMES (:macflotop '#:llcp:fmul))    ; 
      (FQUO   (:macflotop '#:llcp:fdiv))    ; 
      ;
      ; c'est donc une erreur
      ;
      (t (if (setq :f (getfn1 'ld-codop (car obj)))
	     (apply :f obj)
	     (:error "MACHINS" obj)))))
 
;.Section "Les fonctions auxiliaires de ge'ne'ration"

(de :register (arg)
    ; Teste si l'argument est un registre.
    (memq arg '(A1 A2 A3 A4)))

(de :fixp (arg)
    ; Teste si l'ope'rande est un entier (ou pluto^t "(QUOTE entier)")
    ; attention a` la triple e'valuation ...
    (and (consp arg) (eq (car arg) 'QUOTE) (fixp (cadr arg))))

(de :check8 (n)
    ; teste si le deplacement <n> tient sur 8 bits (en fait 7)
    ; Attention a` la tole'rance (de 3 octets de chaque co^te').
    (and (fixp n) (ge n -61) (le n 60) n))
	
(de :check16 (n)
    ; teste si le deplacement <n> tient sur 16 bits (en fait 14)
    ; Attention a` la tole'rance (de 3 octets de chaque co^te').
    (and (fixp n) (ge n -8190) (lt n 8190) n))

(de :adrind-r0 (arg)
    ; charge dans "r0" l'adresse heap de l'objet "arg"
    (if (:register arg)
	(:opnsn #$17			; movd 0(AX),r0
		(selectq arg (A1 #$48) (A2 #$50) (A3 #$58) (A4 #$60))
		#$00)
	(:1byte #$17)			; movd arg,r0
	(:opns-src #$00 arg ())
	(:opnsn #$17 #$40 #$00)))	; movd 0(r0),r0

(de :adrheap-r7 (arg)
    ; Charge dans "r7" l'adresse heap sur la premier valeur de "arg"
    (if (:register arg)
	(:opnsn #$D7			; movd 0(AX),r7
		(selectq arg (A1 #$49) (A2 #$51) (A3 #$59) (A4 #$61))
		#$00)
	(:1byte #$D7)			;  movd arg,r7
	(:opns-src #$01 arg ())
	(:opnsn #$D7 #$79 #$00))	; movd 0(r7),r7
    (:opnsn #$0F #$3A #$0F #$3A))	; addqd 4,r7 / addqd 4,r7

(de :brt2 (b1 b2)
    ; test de type de :arg1 a` 2 bornes : b1, b2
    ; branchement a` :arg2 si vrai.
    (:1byte #$17)			; movd op,r0
    (:opns-src #$00 :arg1 ())
    (:opnsn #$07 #$A8)			; cmpd b1,r0
    (:opns-pos-depl b1)
    (:1byte #$4A)			; bhi end
    (let ((pc (copy :PCcurrent)))
	(:1byte #$00)			; sera resolu a la fin
	(:opnsn #$07 #$A8)		; cmpd b2,r0
	(:opns-pos-depl b2)
	(:opns-branch #$4A :arg2)	; bhi lab
	(memory pc (add1 (subadr :PCcurrent pc)))))

(de :brf2 (b1 b2)
    ; test de type a` 2 bornes de :arg1 avec b1 et b2
    ; branchement a` :arg2 si faux.
    (:1byte #$17)			; movd op,r0
    (:opns-src #$00 :arg1 ())
    (:opnsn #$07 #$A8)			; cmpd b1,r0
    (:opns-pos-depl b1)
    (:opns-branch #$4A :arg2)	; bhi lab
    (:opnsn #$07 #$A8)			; cmpd b2,r0
    (:opns-pos-depl b2)
    (:opns-branch #$5A :arg2))	; bls lab

(de :cnbxx (op)
    ; Comparaison nume'rique entie`re.
    (:opns-arith #$05 #$00 :arg1 :arg2)	; cmpw arg1,arg2
    (:opns-branch op :arg3))

(de :cfbxx (op)
    ; Comparaison nume'rique flottants
    (:1byte #$17)			; movd arg1,r0
    (:opns-src #$00 :arg1 ())
    (:1byte #$D7)			; movd arg2,r7
    (:opns-src #$01 :arg2 ())
    (:opnsn #$BE #$C8 #$43 #$04 #$04)	; cmpl 4(r0),4(r7)
    (:opns-branch op :arg3))

(de :generatecall2subr (fnt lab)
    ; engendre un appel a` la fonction #:llcp:"fnt" avec les arguments
    ; :arg1 :arg2, i.e.  :arg2 op :arg1 -> :arg2.
    ; Avec une pile de la forme suivante :
    ;      ... / :arg2 / adr-ret / :arg1 //
    ; La valeur de retour remplace :arg2, adr-ret et :arg1 sont de'pile's.
    ; chargement de la valeur de retour dans :arg2.
    ; Si lab, branchement a` lab si la valeur retourne'e n'est pas 0
    (:1byte #$17)			; movd \1,r0
    (:opns-src #$00 :arg1 ())
    (let ((:arg2 :arg2))		; protege arg2
	(:ins `(PUSH ,:arg2)))		; movd \2,tos
    (:opnsn #$D7 #$A5)			; movd imm,tos
    (:1double (addadr (copylist :PCcurrent) 15))
    (:opnsn #$D7 #$05)			; movd r0,tos
    (:opnsfvalq 'JMP fnt)		; jump fnt
    (if (and (consp :arg2) (eq (car :arg2) '&))	; le cas vicieux
	(setq :arg2 (list '& (add (cadr :arg2) 1))))
    (ifn lab
	 (:opns-dst #$17 #$B8 :arg2)	; movd tos,\2
	 (:opnsn #$17 #$B8 #$1F #$00)	; movd tos,r0 / cmpqd 0,r0
	 (:opns-branch #$1A lab)))	; bne lab

(de :macflotop (fnt)
    ; ope'ration nume'rique flottante.
    (:generatecall2subr fnt ()))

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

(de :opns-src-dst (b0 b1 src dst)
    ; charge l'instruction NS b0/b1 avec ces deux operandes
    (let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
	(:1byte b0)
	(:1byte b1)
	(setq src (:opns src))
	(setq dst (:opns dst))
	(:1bytePC pc1 pc2 (logor b0 (logand #$FF (logshift dst 6))))
	(:1bytePC+ pc1 pc2
		(logor b1 (logor (logshift src 3) (logshift dst -2))))))

(de :opns-arith (b0 b1 src dst)
    ; charge l'instruction NS b0/b1 avec ces deux operandes
    (let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
	(:1byte b0)
	(:1byte b1)
	(ifn (:fixp src)
	     (setq src (:opns src))
	     (:1word (cadr src))
	     (setq src #$14))
	(ifn (:fixp dst)
	     (setq dst (:opns dst))
	     (:1word (cadr dst))
	     (setq dst #$14))
	(:1bytePC pc1 pc2 (logor b0 (logand #$FF (logshift dst 6))))
	(:1bytePC+ pc1 pc2
		(logor b1 (logor (logshift src 3) (logshift dst -2))))))

(de :opns-src (byte src idst)
    ; charge l'instruction de deuxieme octet byte avec comme source src
    (let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
	(:1byte byte)
	; cas ou il y a un octet d'index pour la destination
	(if idst (:1byte idst))
	; :opns ne genere jamais d'octet d'index
	(setq src (:opns src))
	(:1bytePC pc1 pc2 (logor byte (logshift src 3)))))

(de :opns-dst (b0 b1 dst)
    ; charge l'instruction NS b0/b1 avec comme destination dst
    (let ((pc1 (car :PCcurrent))(pc2 (cdr :PCcurrent)))
	(:1byte b0)
	(:1byte b1)
	(setq dst (:opns dst))
	(:1bytePC pc1 pc2 (logor b0 (logand #$FF (logshift dst 6))))
	(:1bytePC+ pc1 pc2 (logor b1 (logshift dst -2)))))

; .SSection "L'ope'rande NS ge'ne'rique"

(de :opns (op)
    ; charge l'ope'rande NS <op> 
    (cond
       ((eq op 'nil)
	   ; ope'rande nil (en fait ||)
	   #$05)
       ((eq op 'A1)
	   ; accu Le_Lisp
	   #$01)
       ((eq op 'A2)
	   ; accu Le_Lisp
	   #$02)
       ((eq op 'A3)
	   ; accu Le_Lisp
	   #$03)
       ((eq op 'A4)
	   ; accu Le_Lisp
	   #$04)
       ((memq op '(LLINK DLINK ITCOUNT))
	   (:opns-pos-depl (symeval (symbol 'llcp op)))
	   #$15)
       ((memq op '(CBINDN TAG LOCK PROT))
	   (:1double (symeval (symbol 'llcp op)))
	   #$14)
       ((atom op)
	   ; ne doit jamais arriver pour le compilo
	   ; sauf en cas de nouvelles de'finitions.
	   (if (and (symbolp op) 
		    (setq :f (getfn1 'ld-dir op)))
	       (funcall :f op)   
	       (:error "OPNS" op)))
       ((eq (car op) 'quote)
	   ; une constante lisp imme'diate
	   (if (and (null (cadr op)) (null (cddr op)))
	       ; c'est en fait l'ope'rande nil (ou ||)
	       #$05
	       (unless (or (fixp (cadr op))
			   (and :31bitfloats (floatp (cadr op))))
		       ; c'est un litte'ral a` sauver
		   (if (stringp (cadr op))
		       (:add-llitts op)
		       (if (and :stopcopy (consp (cadr op)))
			   (:add-cons-llitt (cadr op) :PCcurrent)
			   (:add-llitt (cadr op)))))
	       (:1double (loc (cadr op)))
	       #$14))
       ((eq (car op) '@)
	   ; une constante adresse me'moire code machine
           ; <lab> est touours une e'tiquette locale;
           ; engendre TOUJOURS un de'placement par rapport au PC.
           ; dans le cas du VAX doit e^tre un de'placement 32 bits...
           ; Les cas utilis'es par le compilateur sont :
           ; MOV, PUSH et BRX qui sont traite's directement.
           ; ?!?! a` terminer ?!?!
	   (:error "OPNS@" op))
       ((eq (car op) '&)
	   ; (& <n>) Le nie`me pointeur de la pile
	   (if (or (not (fixp (cadr op))) (lt (cadr op) 0))
	       (:error "OPNS" op)
	       (:opns-pos-depl (mul 4 (cadr op)))
	       #$19))
       ((memq (car op)
	      '(CAR VAL CVAL CDR PLIST FVAL PKGC OVAL ALINK PNAME TYP))
	   ; adressage indirect indexe'
	   (:1byte (selectq (car op)
		      ((car val cval) 0)
		      ((cdr typ plist) 4)
		      (fval 8)
		      (pkgc 12)
		      (oval 16)
		      (alink 20)
		      (pname 28)
		      (t (:error "OPNS" op))))
	   (selectq (cadr op)
		(A1 #$09)
		(A2 #$0A)
		(A3 #$0B)
		(A4 #$0C)
		(t (:error "OPNS" op))))
       ((eq (car op) 'CVALQ)
	   ; la C-valeur Lisp d'un symbole
	   (ifn (symbolp (cadr op))
		(:error "OPNS" op)
		(:opnsquotesymb (cadr op))))
       ((eq (car op) 'FVALQ)
	   ; la F-valeur Lisp d'un symbole
	   (ifn (symbolp (cadr op))
		(:error "OPNS" op)
		(:opnsquotesymb+8 (cadr op))))
       ((eq (car op) 'EVAL)
	   ; Pour calculer des ope'randes a` load time.
	   (or (car (catcherror t (:opns (eval (cadr op)))))
	       (:error "OPNS" op)))
       (t (if (and (symbolp (car op)) 
		   (setq :f (getfn1 'ld-ind (car op))))
	      (funcall :f op)
	      (:error "OPNS" op)))))

; .SSection "Appel multiple de 1BYTE ou OPNS"

(dmd :opnsn l
     ; appels multiples de :1byte ou :opns
     `(progn ,@(mapcar (lambda (l) `(:1byte ,l)) l)))

; .SSection "Ope'rande de type adresse de symbole Lisp"

(de :opnsquotesymb (symb)
    ; charge un ope'rande de type "adresse de symbole"
    ; <symb> est toujours de type symbole.
    (:add-llitt symb)
    (setq :valaux (subadr (loc symb) :locnil))
    (:opns-pos-depl :valaux)
    #$0D)

(de :opnsquotesymb+8 (symb)
    ; charge un ope'rande de type "adresse de symbole" + 8
    ; <symb> est toujours de type symbole.
    (:add-llitt symb)
    (setq :valaux (incradr (subadr (loc symb) :locnil) 8))
    (:opns-pos-depl :valaux)
    #$0D)

; .Section "Gestion des e'tiquettes"

; .SSection "Les e'tiquettes globales (JCALL/JMP)"

(de :opnsfvalq (type symb)
    ; la F-valeur Lisp d'un symbole pour un JCALL/JMP
    ; type = JMP ou JCALL
    (:add-llitt symb) ; temporairement (il de'gage avec :clean-llitt)
    (cond ((and (setq :valaux (cassq symb :llabels))
		(:check16 (setq :valaux (subadr :valaux :PCcurrent))))
	   ; FENTRY si de'ja` de'fini dans le me^me module et pas loin.
	   ; Un call/jmp relatif sur 16 bits est moins cher que FVALQ
	   (:1byte (if (eq type 'JMP) #$EA #$02))	; br / bsr
	   (if (:check8 :valaux)
	       ; cas br avec byte displ
	       (:1byte (logand #$7F :valaux))
	       ; cas br avec word displ
	       (:1word (logor #$8000 (logand #$3FFF :valaux)))))
	  (t
	   ; Etiq globale : direct sur la FVAL
	   ; ca coute une indirection mais fait gagner parfois (pour les
	   ; fonctions standard toujours) 2 octets.
	   ; gain de 6k nets apre`s llcp-std!
	   (:opnsn #$17 #$68)			; movd n(r5),r0
	   (setq :valaux (subadr (loc symb) :locnil))
	   (:opns-pos-depl (incradr :valaux 8))
	   (:1byte #$7F)
	   (:1byte (if (eq type 'JMP) #$42 #$46))  ; jump / jsr 0(r0)
	   (:1byte #$00))))

; .SSection "Calcul de la valeur d'une e'tiquette qui existe"
 
(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)))))
 
(de :valadrel (adr)
    ; retourne un de'placement par rapport a` PC ou ()
    (when (setq adr (:valadr adr)) (subadr adr :PCcurrent)))

(de :opns-brx (base adr)
    ; le cas special pour le BRX
    (if (and (consp adr) (eq (car adr) '@))
	(setq adr (cadr adr))
	(:error "OPNS-BRX" adr))
    (setq :valaux (:valadr adr))
    (if :valaux
	; existe deja
	(ifn (:check16 (setq :valaux (subadr :valaux base)))
	     (:error "BRX too long" adr)
	     (:1byte (logand #$FF :valaux))
	     (:1byte (logand #$FF (logshift :valaux -8))))
	(if (and (symbolp adr) (null (assq adr :llabels)))
	    ; dans les ENTRY
	    (:addentry adr base)
	    ; dans les LOCAL
	    (:addlabel adr base))
	(:1word 0)))

; .SSection "Branchements conditionnels locaux"

(de :opns-branch (code adr)
    ; charge le code <code> de branchement conditionnel vers <adr>.
    ; L'e'tiquette <adr> est toujours locale.
    (setq :valaux (:valadrel adr))
    (cond
	 ((:check8 :valaux)
	  ; branchement arriere sur 8 bits
	  (:1byte code)
	  (:1byte (logand #$7F :valaux)))
	 ((:check16 :valaux)
	  ; branchement arriere sur 16 bits
	  (:1byte code)
	  (:1byte (logor #$80 (logand #$3F (logshift :valaux -8))))
	  (:1byte (logand #$FF :valaux)))
	 (:valaux
	  ; branchement arriere sur 32 bits
	  (:1byte code)
	  (cond
	     ((consp :valaux)
	      (:1word (logor #$C000 (logand #$3FFF (car :valaux))))
	      (setq :valaux (cdr :valaux)))
	     ((ge :valaux 0) (:1word #$C000))
	     (t (:1word #$FFFF)))
	  (:1word :valaux))
	 ((:notoofar8 adr :lobj)
	  ; branchement avant sur 8 bits
	  (:1byte code)
	  (:addlabel adr 8)
	  (:1byte 0))
	 ((and (or (fixp adr) (assq adr :llabels)) (:notoofar16 adr :lobj))
	  ; branchement avant sur 16 bits
	  (:1byte code)
	  (:addlabel adr 16)
	  (:1word 0))
	 ((and (symbolp adr) (not (assq adr :llabels)) (:notoofar adr :lobj))
	  ; branchement avant sur 16 bits
	  (:1byte code)
	  (:addentry adr 16)
	  (:1word 0))
	 (t ; branchement avant sur 32 bits
	    (:1byte code)
	    (if (and (symbolp adr) (null (assq adr :llabels)))
		; dans les ENTRY
		(:addentry adr 32)
		; dans les LOCAL
		(:addlabel adr 32))
	    (:1double 0))))

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

(de :opns-depl (val)
    ; charge le deplacement val
    (cond
	((fixp val)
	 (cond
	    ((and (ge val -64) (lt val 64))
	     (:1byte (logand #$7F val)))
	    ((and (ge val -8192) (lt val 8192))
	     (:1word (logor #$8000 (logand #$3FFF val))))
	    (t (if (ge val 0) (:1word #$C000) (:1word #$FFFF))
	       (:1word val))))
	((and (consp val) (fixp (car val)))
	 (:1word (logor #$C000 (logand #$3FFF (car val))))
	 (:1word (cdr val)))
	((and (consp val) (eq (car val) '@))
	 (setq :valaux (:valadr (cadr val)))
	 (if :valaux
	     (:opns-depl :valaux)
	     (if (and (symbolp (cadr val)) (null (assq (cadr val) :llabels)))
		 (:addentry (cadr val) 0)
		 (:addlabel (cadr val) 0))
	     (:1double 0)))
	(t (:error "Opns-Depl" val))))

(de :opns-pos-depl (val)
    ; charge le deplacement positif val
    (cond
	((fixp val)
	 (cond
	    ((and (ge val 0) (lt val 64))
	     (:1byte (logand #$3F val)))
	    ((and (ge val 0) (lt val 8192))
	     (:1word (logor #$8000 (logand #$1FFF val))))
	    (t (:1word #$C000)
	       (:1word val))))
	((and (consp val) (fixp (car val)))
	 (:1word (logor #$C000 (logand #$1FFF (car val))))
	 (:1word (cdr val)))
	((and (consp val) (eq (car val) '@))
	 (setq :valaux (:valadr (cadr val)))
	 (if :valaux
	     (:opns-pos-depl :valaux)
	     (if (and (symbolp (cadr val)) (null (assq (cadr val) :llabels)))
		 (:addentry (cadr val) 0)
		 (:addlabel (cadr val) 0))
	     (:1double 0)))
	(t (:error "Opns-Pos-Depl" val))))

;.SSection "chargement d'1 octet"

(de :1byte (obj)
    ; charge l'octet obj
    (when :talkp
	  (when (gt :nwl 10)
		(setq :nwl 0)
		(terpri)
		(outpos 30)
		(:prinhex :PCcurrent)
		(prin "  "))
	  (incr :nwl)
	  (prin " ")
	  (:prinhexb obj))
    (memory :PCcurrent obj)
    (incradr :PCcurrent 1))

(de :1bytePC (pc1 pc2 val)
    ; ne cons pas !
    (let ((adr '(0 . 0)))
	(rplac adr pc1 pc2)
	(memory adr val)))

(de :1bytePC+ (pc1 pc2 val)
    ; ne cons pas !
    (let ((adr '(0 . 0)))
	(rplac adr pc1 pc2)
	(incradr adr 1)
	(memory adr val)))

(de :1byterelPC (adr)
    ; charge le de'placement relatif a` PCcurrent pour l'adresse adr
    (setq :valaux (incradr (subadr :PCcurrent adr) 1))
    (if (or (not (fixp :valaux)) (lt :valaux -64) (ge :valaux 64))
	(:error "1byterelPC" :module))
    (memory adr (logand #$7F :valaux)))

(de :align ()
    ; aligne le compteur de chargement sur une
    ; frontie`re de mots de 32 bits (merci NS)
    (until (eq (logand 3 (if (fixp :PCcurrent)
			     :PCcurrent
			     (cdr :PCcurrent)))
	       0)
	    (:1byte #$A2)))   ; charge un NOP!
 
;.SSection "chargement d'1 seul mot de 16 bits"
 
(de :1word (obj)
    ; charge 1 mot obj : attention a` l'ordre.
    (:1byte (logand (logshift obj -8) #$FF))
    (:1byte (logand obj #$FF)))

(de :1wordrel (base adr)
    ; charge le de'placement relatif a PCcurrent et base pour adr
    (setq :valaux (subadr :PCcurrent base))
    (if (or (not (fixp :valaux)) (lt :valaux -8192) (ge :valaux 8192))
	(:error "Brx trop gros" :module))
    (memory adr (logand #$FF :valaux))
    (memory (incradr adr 1) (logand #$FF (logshift :valaux -8))))

(de :1wordrelPC (adr)
    ; charge le de'placement relatif a` PCcurrent pour l'adresse adr
    (setq :valaux (incradr (subadr :PCcurrent adr) 1))
    (if (or (not (fixp :valaux)) (lt :valaux -8192) (ge :valaux 8192))
	(:error "Module trop gros" :module))
    (memory adr (logor #$80 (logand #$3F (logshift :valaux -8))))
    (memory (incradr adr 1) (logand #$FF :valaux)))

; .SSSection "Chargement par paquet de 32 bits"

(de :1double (val)
    ; charge la valeur <val> sur 32 bits
    (cond ((fixp val)
	   (:1word 0)
	   (:1word val))
	  ((consp val)
	   (:1word (car val))
	   (:1word (cdr val)))
	  (t (:error "1DOUBLE" val))))

(de :1doublePC (where)
    ; charge PCcurrent a where
    (let ((adr (copylist where)))
       (memory adr (logor #$C0 (logand #$3F (logshift (car :PCcurrent) -8))))
       (incradr adr 1)
       (memory adr (logand #$FF (car :PCcurrent)))
       (incradr adr 1)
       (memory adr (logshift (cdr :PCcurrent) -8))
       (incradr adr 1)
       (memory adr (logand #$FF (cdr :PCcurrent)))))

(de :1doublerelPC (adr)
    ; charge le de'placement relatif a` PCcurrent pour l'adresse adr
    (setq :valaux (incradr (subadr :PCcurrent adr) 1))
    (if (fixp :valaux) (setq :valaux (cons (if (ge :valaux 0) 0 -1) :valaux)))
    (memory adr (logor #$C0 (logand #$3F (logshift (car :valaux) -8))))
    (memory (incradr adr 1) (logand #$FF (car :valaux)))
    (memory (incradr adr 1) (logand #$FF (logshift (cdr :valaux) -8)))
    (memory (incradr adr 1) (logand #$FF (cdr :valaux))))

; .Section "Fonctions de gestion des tables d'e'tiquettes"

(defvar :long-ins '(HBMOVX HBXMOV HPMOVX HPXMOV FPLUS FDIFF FTIMES FQUO))

(de :notoofar8 (adr lobj)
    ; heuristique pour les branchements sur 8 bits
    (tag ok
	 (let ((count 7)(e))
	    (while (and (gt count 0) (consp lobj))
		   (nextl lobj e)
		   (cond
			((atom e) (if (eq e adr) (exit ok t)))
			((eq (car e) 'BRX) (exit ok ()))
			((memq (car e) :long-ins)
			 (setq count (sub count 3)))
			(t (setq count (sub1 count)))))
	    ())))

(de :notoofar16 (adr lobj)
    ; heuristique pour les branchements sur 16 bits
    (tag ok
	 (repeat 500
		 (when (eq (nextl lobj) adr)
		       (exit ok t)))
	 ()))

(de :notoofar (adr lobj)
    ; heuristique pour les branchements (etiquette symbolique)
    (tag ok
	 (repeat 500
		 (nextl lobj :valaux)
		 (if (and (consp :valaux)
			  (eq (car :valaux) 'entry)
			  (eq (cadr :valaux) adr))
		     (exit ok t)))
	 ()))

(de :addlabel (sym depl)
    ; rajoute le symbole <sym> dans la table des re'fe'rences avants
    ; locales non re'solues a` l'adresse PCcurrent.
    ; Avec un deplacement de <depl> (8/16/32) ou 0 pour absolu
    ; retourne 0 (adresse inconnue)
    (setq :valaux (assq sym :llabels-nr))
    (setq depl (cons depl (copylist :PCcurrent)))
    (if :valaux
	(rplacd :valaux (cons depl (cdr :valaux)))
	(newl :llabels-nr (list sym depl)))
    0)
 
(de :addentry (sym depl)
    ; rajoute le symbole <sym> une dans la table des re'fe'rences avants
    ; des ENTRY non re'solus a` l'adresse du PCcurrent.
    ; retourne 0 (adresse inconnue)
    (setq :valaux (assq sym :entries-not-resolved))
    (setq depl (cons depl (copylist :PCcurrent)))
    (if :valaux
	(rplacd :valaux (cons depl (cdr :valaux)))
	(newl :entries-not-resolved (list sym depl)))
    0)

; .Section "Gestion de la table des litte'raux"
 
(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)))))

(de :add-cons-llitt (c a)
    (newl :local-cons-llitt (cons (vag a) c)))

; .Section "Fonction d'impression hexa"
 
(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)
	   (:prinhex (car n))
	   (:prinhex (cdr n)))
	  (t (error 'memory-dump 'errnna n))))
 
(de :prinhexb (n)
    ; imprime sur 2 chiffres hexa le nb n
    (cond ((not (fixp n)) (error 'memory-dump 'errnna n))
	  ((lt n 0) (setq n 255))
	  ((lt n 16) (princn #/0)))  
    (with ((obase 16)) (prin n)))

; .Section "Fonction de debug"
 
(de memory-dump (adr n)
    ; dump la memoire en hexa de <adr> sur <n> mots
    ; attention au SWAB du NS! octet de poids faibles a gauche!
     (setq adr (copy adr))      ;  pour le incradr
     (until (< n 0)
	    (:prinhex adr)
	    (outpos 10)
	    (let ((adr (copylist adr)))
		 (repeat 16
			 (:prinhexb (memory adr))
			 (prin " ")
			 (incradr adr 1)))
	   (prin "  ")
	   (repeat 16
	   (if (and (> (memory adr) 32) (< (memory adr) 128))
	       (princn (memory adr))
	       (princn #/.))
	   (incradr adr 1) )
	   (decr n)
	   (terpri)))
 
; .Section "Fonction auxiliaire d'erreur"
 
(de :error (f a)
    ; erreur de type <f> les argments de'fecteux sont dans <a>
    (terpri)
    (print "***** LOADER : erreur durant le chargement de : " :fntname)
    (print "      type de l'erreur     : " f)
    (print "      arguments de'fecteux : " a)
    (exit :tagerr))
 
;.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-nr) 		; 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
	  :valaux       		;    itou pour des valeurs locales.
	  :f    			;    itou (pour des getfn1)
	  (:nwl 0)      		;    itou pour tabler le code produit.
	  :local-cons-llitt)     	;    les literaux cons locaux
      ; 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)
		       ; actualise les literaux cons
		       (if (and :stopcopy (typefn ':patch-cons-llitt))
			   (:patch-cons-llitt))
		       ; actualise #:ld:cons-llitt
		       (setq #:ld:cons-llitt
			     (nconc :local-cons-llitt #:ld:cons-llitt)))
       ()))

; .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) )
	 () )
      (if :stopcopy
	  (loader '(
		(fentry #:ld:gcafter-daemon subr0) ; le daemon !!!
		(mov (cvalq #:ld:cons-llitt) a4)   ; les literaux a patcher
	     5  (btnil a4 6)       		; il en reste ?
		(mov (car a4) a1)  		; A1 = (code . cons)
		(mov (cdr a4) a4)  		; la suite
		(mov (cdr a1) a2)  		; A2 = le cons
		(mov (car a1) a1)  		; A1 = le code
		; INVERSION
		(push '0)
		(push a2)
		(eval (:opnsn #$54 #$CE 0 7))
		(eval (:opnsn #$54 #$CE 1 6))
		(eval (:opnsn #$54 #$CE 2 5))
		(eval (:opnsn #$54 #$CE 3 4))
		(adjstk '1)
		(pop a2)
		; INVERSE
		(mov a2 (car a1))  		; cons -> *code
		(bra 5)    			; on continue
	     6  (return)   			; c'est fini
		(fentry :patch-cons-llitt subr0)   ; contre les courses
		(push a1)  			; sauve les registres
		(push a2)
		(push a3)
		(push a4)
		(mov (cvalq :local-cons-llitt) a4) ; les literaux locaux
		(call 5)   			; patche
		(pop a4)   			; remet les registres
		(pop a3)
		(pop a2)
		(pop a1)
		(return)
		(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 'ldns) ))