;;; .EnTete "Le-Lisp (c) version 15.2" " " "Le chargeur me'moire VAX"
;;; .EnPied " " "%" " "
;;; .sp 2
;;; .SuperTitre "Le Chargeur Me'moire VAX"
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA. "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA "
;;; .Centre "*****************************************************************"
; .Centre "$Header: lapvax.ll,v 4.1 88/01/13 12:21:29 kuczynsk Rel $"
; Assemble et charge pour un VAX une liste d'instructions LLM3
; en 1 seule passe et avec du code relogeable.
(unless (>= (version) 15.2)
(error 'load 'erricf 'lapvax))
(defvar #:sys-package:colon 'ldvax)
(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` 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 :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"
(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 :localstack :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)))
; cet :align fait perdre 3k code dans Le←Lisp standard!
; (:align)
; re'solution des re'fe'rences avants (relatives)
(mapc (lambda (l)
(selectq (caar l)
(8 ; c'est une r.n.r. relative sur 8 bits
(setq :valaux
(sub1 (subadr :PCcurrent (cdar l))))
(if (or (lt :valaux 0) (gt :valaux 126))
(:error "RESOL"
(list l :valaux obj))
(memory (cdar l) :valaux)))
(16 ; c'est une r.n.r. relative sur 16 bits
(:1wordrelPC (cdar l) (cdr l)))
(t (:error "RESOL" 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)
:localstack 0)
(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 ':1wordrelPC
(cassq :arg1 :entries-not-resolved)
(cirlist 0))
(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) '@))
(:1byte #$DE) ; moval
(:opvaxshortad (cadr :arg1)))
((and (consp :arg1)
(eq (car :arg1) 'QUOTE)
(symbolp (cadr :arg1)))
(:1byte #$DE) ; moval
(:opvaxquotesymb (cadr :arg1)))
(t
(:opvaxn #$D0 :arg1))) ; movl src,
(:opvax :arg2)) ; dest
;
; Les instructions de contro↑le
;
(BRA ; (BRA <lab>) == brb/brw lab
(:brarel #$11 #$31 :arg1))
(BRI ; (BRI <op>) == jmp (<op>)
(cond
((:register :arg1)
(:opvaxn #$17 (list 'val :arg1))); jmp (op)
(t (:opvaxn #$D0 :arg1 #$50) ; movl op,r0
(:opvaxn #$17 #$60)))) ; jmp (r0)
(BRX ; (BRX (<lab1> <lab2> ... <labn>) <index>)
; casew :arg2,#0,(length :arg1)
(:1byte #$AF) ; casew
(:opvax :arg2) ; :arg2,
(:1byte 0) ; $0,
(let ((temp (sub1 (length :arg1))))
(if (< temp 64) ; imme'diat long ou court ?
(:1byte temp)
(:1byte #$8F) ; (pc)+
(:1word temp))) ; car caseW
(let ((val) (n 0))
(mapc (lambda (etq)
(setq val (:valadrel (cadr etq)))
(cond
((:check16 val)
(:1word (add val n))
(setq n (add n 2)))
(t (:addlabel (cadr etq) 16 (setq n (add n 2)))
(:1word 0))))
:arg1)))
(CALL ; (CALL etiq) == bsbb/bsbw etiq (cf BRA)
(:brarel #$10 #$30 :arg1))
(JCALL ; (JCALL <sym>) == jsb (FVAL :arg1)
(:opvaxgofvalq :codop :arg1)) ; bsbb/bsbw/jsb arg1
(JMP ; (JMP <sym>) == (JMP) (FVAL <sym>)
(:opvaxgofvalq :codop :arg1)) ; brb/brw/jmp arg
(RETURN ; (RETURN)
(:1byte #$05))
(SOBGEZ ; (SOBGEZ op lab) decw op / bgeq lab
(:opvaxn #$B7 :arg1)
(:vxcondbr #$18 :arg2))
;
; les instructions sur la pile de donne'e
;
(POP ; (POP <op>) == movl (sp)+,op
(:opvaxn #$D0 #$8E :arg1))
(PUSH ; (PUSH <op>)
(cond ((and (consp :arg1)
(eq (car :arg1) '@))
(:1byte #$DF) ; pushal
(:opvaxshortad (cadr :arg1)))
((and (consp :arg1)
(eq (car :arg1) 'QUOTE)
(symbolp (cadr :arg1)))
(:1byte #$DF) ; pushal
(:opvaxquotesymb (cadr :arg1)))
(t
(:opvaxn #$DD :arg1)))) ; pushl
(SSTACK ; (SSTACK <op>) movl op,sp
(:opvaxn #$D0 :arg1 #$5E))
(STACK ; (STACK <op>) movl sp,op
(:opvaxn #$D0 #$5E :arg1))
(XSPMOV ; (XSPMOV depl val)
; on ajoute le de'placement au haut de pile
; on optimise quand c'est un entier
(if (:fixp :arg1)
(:opvaxn #$C1 (kwote (mul 4 (cadr :arg1)))
#$5E #$51) ; addl3 depl*4,sp,r1
(:opvaxn #$9C #$02 :arg1 #$50) ; rotl $2,depl,r0
(:opvaxn #$C1 #$50 #$5E #$51)) ; addl3 r0,sp,r1
; on charge la valeur comme il le faut
(:opvaxn #$D0 #$61 :arg2)) ; movl (r1),val
;
; les tests de type
;
(BTNIL ; (BTNIL op lab)
; cmpl regNIL,op / beql lab
(:brtf1 #$58 #$13))
(BFNIL ; (BFNIL op lab)
; cmpl regNIL,op / bneq lab
(:brtf1 #$58 #$12))
(BTCONS ; (BTCONS op lab)
; cmpl bcons,op / bleq lab
(:brtf1 #$5A #$15))
(BFCONS ; (BFCONS op lab)
; cmpl bcons,op / bgtr lab
(:brtf1 #$5A #$14))
(BTFIX ; (BTFIX op1 lab)
; cmpl bfloat,op1 / bgtru lab
(:brtf1 #$5C #$1A))
(BFFIX ; (BFFIX op1 lab)
; cmpl bfloat,op1 / blequ lab
(:brtf1 #$5C #$1B))
(BTFLOAT ; (BTFLOAT op1 lab)
(if :31bitfloats
(:brtf1 0 #$14)
(:brt2 #$5C #$57)))
(BFFLOAT ; (BFFLOAT op1 lab)
(if :31bitfloats
(:brtf1 0 #$15)
(:brf2 #$5C #$57)))
(BTSTRG ; (BTSTRG op1 lab)
(:brt2 #$56 #$58))
(BFSTRG ; (BFSTRG op1 lab)
(:brf2 #$56 #$58))
(BTVECT ; (BTVECT op1 lab)
(:brt2 #$57 #$56))
(BFVECT ; (BFVECT op1 lab)
(:brf2 #$57 #$56))
(BTSYMB ; (BTSYMB op1 lab)
(:brt2 #$58 #$5A))
(BFSYMB ; (BFSYMB op1 lab)
(:brf2 #$58 #$5A))
(BTVAR ; (BTVAR op1 lab)
(:brt2 #$59 #$5A))
(BFVAR ; (BFVAR op1 lab)
(:brf2 #$59 #$5A))
(CABEQ ; (CABEQ op1 op2 lab)
; cmpl op1 op2 / beql lab
(:opvaxn #$D1 :arg1 :arg2)
(:vxcondbr #$13 :arg3))
(CABNE ; (CABNE op1 op2 lab)
; cmpl op1 op2 / bneq lab
(:opvaxn #$D1 :arg1 :arg2)
(:vxcondbr #$12 :arg3))
;
; Les autres instructions (par ordre alpha)
;
(ADJSTK ; (ADJSTK 'nb)
(if (:fixp :arg1)
(unless (eq (cadr :arg1) 0)
(if (gt (cadr :arg1) 0)
(:opvaxn #$C0 (kwote (mul 4 (cadr :arg1))) #$5E)
(:opvaxn #$C2 (kwote (mul 4 (sub 0 (cadr :arg1)))) #$5E)))
(:opvaxn #$9C #$02 :arg1 #$50) ; rotl $2,:arg1,r0
(:opvaxn #$C0 #$50 #$5E))) ; addl2 r0,sp
(CAR ; (CAR A1/A2/A3) == movl (rx),rx ?!?!? obsolete
(:opvaxn #$D0 `(CAR ,:arg1) :arg1))
(CDR ; (CDR A1/A2/A3) == movl 4(rx),rx ?!?!?!? obsolete
(:opvaxn #$D0 `(CDR ,:arg1) :arg1))
(HBMOVX ; (HBMOVX val string index) val -> string[index]
(:adrheap-r1 :arg2) ; r1 <- adr heap de arg2
; on optimise quand c'est un entier ou un registre
(cond ((:fixp :arg3)
(:1byte #$90) ; movb val,index*4+8(r1)
(:opvax-byte :arg1)
(:opvaxi #$A1 #$C1 (add 8 (cadr :arg3))))
((:register :arg3)
(:1byte #$90) ; movb val,8[arg3](r1)
(:opvax-byte :arg1)
(:1byte
(selectq :arg3
(A1 #$42) (A2 #$43) (A3 #$44) (A4 #$45)))
(:opvaxn #$A1 8))
(t (:opvaxn #$D0 :arg3 #$50) ; movl :arg3,r0
(:1byte #$90) ; movb val,8[r0](r1)
(:opvax-byte :arg1)
(:opvaxn #$40 #$A1 8))))
(HBXMOV ; (HBXMOV string index dest) string[index] -> dest
(:adrheap-r1 :arg1) ; r1 <- adr heap de arg1
; on optimise quand c'est un entier ou un registre
(cond ((:fixp :arg2)
(:1byte #$9A) ; movzbl index*4+8(r1),val
(:opvaxi #$A1 #$C1 (add 8 (cadr :arg2)))
(:opvax :arg3))
((:register :arg2)
(:1byte #$9A) ; movzbl 8[arg3](r1),val
(:1byte
(selectq :arg2
(A1 #$42) (A2 #$43) (A3 #$44) (A4 #$45)))
(:opvaxn #$A1 8 :arg3))
(t (:opvaxn #$D0 :arg2 #$50) ; movl :arg2,r0
(:opvaxn #$9A #$40 #$A1 8 :arg3)))) ; movzbl 8[r0](r1),val
(HGSIZE ; (HGSIZE vector/string arg2)
(:adrheap-r1 :arg1) ; r1 <- adr heap de arg2
; on ajoute le de'placement de 4 et transfert le resultat
(:opvaxn #$D0 #$A1 4 :arg2)) ; movl 4(r1),:arg2
(HPMOVX ; (HPMOVX val vector index)
(:adrheap-r1 :arg2) ; r1 <- adr heap de arg2
; on optimise quand c'est un entier ou un registre
(cond ((and (:fixp :arg3) (lt (cadr :arg3) #.(- #$4000 8)))
(:opvaxn #$D0 :arg1) ; movl val,index*4+8(r1)
(:opvaxi #$A1 #$C1 (add 8 (mul 4 (cadr :arg3)))))
((:register :arg3)
(:opvaxn #$D0 :arg1) ; movl val,8[arg3](r1)
(:1byte
(selectq :arg3
(A1 #$42) (A2 #$43) (A3 #$44) (A4 #$45)))
(:opvaxn #$A1 8))
(t (:opvaxn #$D0 :arg3 #$50) ; movl :arg3,r0
(:opvaxn #$D0 :arg1 ; movl val,8[r0](r1)
#$40 #$A1 8))))
(HPXMOV ; (HPXMOV vector index val)
(:adrheap-r1 :arg1) ; r1 <- adr heap de arg1
; on optimise quand c'est un entier ou un registre
(cond ((and (:fixp :arg2) (lt (cadr :arg2) #.(- #$4000 8)))
(:1byte #$D0) ; movl index*4+8(r1),val
(:opvaxi #$A1 #$C1 (add 8 (mul 4 (cadr :arg2))))
(:opvax :arg3))
((:register :arg2)
(:1byte #$D0) ; movl 8[arg3](r1),val
(:1byte
(selectq :arg2
(A1 #$42) (A2 #$43) (A3 #$44) (A4 #$45)))
(:opvaxn #$A1 8 :arg3))
(t (:opvaxn #$D0 :arg2 #$50) ; movl :arg2,r0
(:opvaxn #$D0 #$40 #$A1 8 :arg3)))) ; movl 8[r0](r1),val
(MOVXSP ; (MOVXSP val depl)
; on ajoute le de'placement au haut de pile
; on optimise quand c'est un entier
(if (:fixp :arg2)
(:opvaxn #$C1 (kwote (mul 4 (cadr :arg2)))
#$5E #$51) ; addl3 depl*4,sp,r1
(:opvaxn #$9C #$02 :arg2 #$50) ; rotl $2,depl,r0
(:opvaxn #$C1 #$50 #$5E #$51)) ; addl3 r0,sp,r1
; on charge la valeur comme il le faut
(:opvaxn #$D0 :arg1 #$61)) ; movl val,(r1)
(NOP ; (NOP) ne fait rien mais perd du temps et de la place
(:1byte 1))
;
; Les comparaisons arithme'tiques entieres. cmpw op1 op2 / bnxx lab
;
(CNBEQ ; (CNBEQ op1 op2 lab)
(:cnbxx #$13))
(CNBNE ; (CNBNE op1 op2 lab)
(:cnbxx #$12))
(CNBLT ; (CNBLT op1 op2 lab)
(:cnbxx #$19))
(CNBLE ; (CNBLE op1 op2 lab)
(:cnbxx #$15))
(CNBGT ; (CNBGT op1 op2 lab)
(:cnbxx #$14))
(CNBGE ; (CNBGE op1 op2 lab)
(:cnbxx #$18))
;
; Les comparaisons arithme'tiques flottantes.
;
(CFBEQ ; (CFBEQ op1 op2 lab)
(:cfbxx #$13))
(CFBNE ; (CFBNE op1 op2 lab)
(:cfbxx #$12))
(CFBLT ; (CFBLT op1 op2 lab)
(:cfbxx #$19))
(CFBLE ; (CFBLE op1 op2 lab)
(:cfbxx #$15))
(CFBGT ; (CFBGT op1 op2 lab)
(:cfbxx #$14))
(CFBGE ; (CFBGE op1 op2 lab)
(:cfbxx #$18))
;
; Les instructions arithme'tiques (par ordre alpha)
;
(DECR ; (DECR op) == decw op
(:opvaxn #$B7 :arg1))
(DIFF ; (DIFF op1 op2) == subw2 op1 op2 ou decw op2
; op2 - op1 -> op2
(if (equal :arg1 ''1)
(:opvaxn #$B7 :arg2)
(:1byte #$A2)
(:opvax-word :arg1)
(:opvax :arg2)))
(INCR ; (INCR op) == incw op
(:opvaxn #$B6 :arg1))
(LAND ; (LAND op1 op2) mcomw op1 r0 / bicw2 r0 op2
(:1byte #$B2) ; mcomw
(:opvax-word :arg1)
(:1byte #$50)
(:1byte #$AA)
(:1byte #$50)
(:opvax-word :arg2))
(LOR ; (LOR op1 op2) == bisw2 op1 op2
(:1byte #$A8)
(:opvax-word :arg1)
(:opvax-word :arg2))
(LXOR ; (LXOR op1 op2) == xorw2 op1 op2
(:1byte #$AC)
(:opvax-word :arg1)
(:opvax-word :arg2))
(LSHIFT ; (LSHIFT circ op) == rotl circ,op,op puis masque
(if (null (:fixp :arg1))
(:opvaxn #$9C :arg1 :arg2 :arg2)
; cas bizarre car la constante doit e↑tre sur 8 bits signe's.
(:1byte #$9C)
(:1byte #$8F)
(:1byte (logand #$FF (cadr :arg1)))
(:opvax :arg2)
(:opvax :arg2))
; bicl2 $0xFFFF0000 op
(:1byte #$CA) (:1byte #$8F) ; (pc)+
(:1byte 0) (:1byte 0)
(:1byte #$FF) (:1byte #$FF)
(:opvax :arg2))
(NEGATE ; (NEGATE op) == mnegw op,op ou
(:opvaxn #$AE :arg1 :arg1))
(PLUS ; (PLUS op1 op2) == addw2 op1 op2 ou incw op
(if (equal :arg1 ''1)
(:opvaxn #$B6 :arg2)
(:1byte #$A0)
(:opvax-word :arg1)
(:opvax :arg2)))
(REM ; (REM op1 op2)
(:opvaxn #$D0 :arg2 #$50) ; movl \2 r0
(:opvaxn #$D0 :arg1 #$51) ; movl \1 r1
(:opvaxn #$A6 #$51 :arg2) ; divw2 r1 \2
(:opvaxn #$A4 #$51 :arg2) ; mulw2 r1 \2
(:opvaxn #$A2 :arg2 #$50) ; subw2 \2 r0
(:opvaxn #$3C #$50 :arg2)) ; movzwl r0 \2
(QUO ; (QUO op1 op2) == divw2 op1 op2
; op2 / op1 -> op2
(:1byte #$A6)
(:opvax-word :arg1)
(:opvax :arg2))
(TIMES ; (TIMES op1 op2) == mulw2 op1 op2
(:1byte #$A4)
(:opvax-word :arg1)
(:opvax :arg2))
;
; Les instructions arithme'tiques flottantes
;
(FPLUS (:macflotop #$40 '#:llcp:fadd)) ; addf2
(FDIFF (:macflotop #$42 '#:llcp:fsub)) ; subf2
(FTIMES (:macflotop #$44 '#:llcp:fmul)) ; mulf2
(FQUO (:macflotop #$46 '#:llcp:fdiv)) ; divf2
;
; 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 l'adresse ou le nb <n> tient sur 8 bits
; Attention a` la tole'rance (de 3 octets de chaque co↑te').
(if (and (fixp n)
(ge n -125)
(le n 124))
n
()))
(de :check16 (n)
; teste si l'adresse ou le nb <n> tient sur 16 bits
; a` revoir le coup du 15e`me bit!!! (0 . #$8000)
(cond ((null n) ())
((fixp n) n)
((consp n)
(if (or (eq (car n) 0) (eq (car n) -1))
(cdr n)
(:error "CHECK16" n)
0))
(t (:error "CHECK16" n)
0)))
(de :adrheap-r1 (arg)
; Charge dans "r1" l'adresse heap de l'objet "arg"
(if (:register arg)
(:opvaxn #$D0 `(VAL ,arg) #$51) ; movl (vector),r1
(:opvaxn #$D0 arg #$51) ; movl vector,r1
(:opvaxn #$D0 #$61 #$51))) ; movl (r1),r1
(de :brtf1 (reg br)
; test de type a` une borne
; si cmpl reg :arg1, br :arg2
(:1byte #$D1) ; cmpl
(:1byte reg) ; reg
(:opvax :arg1) ; ,arg1
(:vxcondbr br :arg2))
(de :brt2 (reg1 reg2)
; test de type de :arg1 a` 2 bornes : reg1, reg2
; branchement a` :arg2 si vrai.
(:1byte #$D1)
(:1byte reg1)
(:opvax :arg1)
(:1byte #$1A)
(let ((pc (copy :PCcurrent)))
(:1byte 0) ; sera re'solu a` la fin
(:1byte #$D1)
(:1byte reg2)
(:opvax :arg1)
(:vxcondbr #$1A :arg2)
(memory pc (sub1 (subadr :PCcurrent pc)))))
(de :brf2 (reg1 reg2)
; test de type a` 2 bornes de :arg1 avec reg1 et reg2
; branchement a` :arg2 si faux.
(:1byte #$D1)
(:1byte reg1)
(:opvax :arg1)
(:vxcondbr #$1A :arg2)
(:1byte #$D1)
(:1byte reg2)
(:opvax :arg1)
(:vxcondbr #$1B :arg2))
(de :cnbxx (op)
; Comparaison nume'rique entie`re.
(:1byte #$B1) ; cmpw
(:opvax-word :arg1) ; arg1,
(:opvax-word :arg2) ; arg2
(:vxcondbr op :arg3))
(de :cfbxx (op)
; Comparaison nume'rique flottants
(cond ((not :31bitfloats) ; du vrai 64 bits.
(unless (:register :arg1)
(:opvaxn #$D0 :arg1 #$50)) ; movl :arg1 r0
(unless (:register :arg2)
(:opvaxn #$D0 :arg2 #$51)) ; movl :arg2 r1
(:1byte #$71) ; cmpd 4(\1) 4(\2)
(:1byte (selectq :arg1
(A1 #$A2) (A2 #$A3) (A3 #$A4) (A4 #$A5) (t #$A0)))
(:1byte 4)
(:1byte (selectq :arg2
(A1 #$A2) (A2 #$A3) (A3 #$A4) (A4 #$A5) (t #$A1)))
(:1byte 4))
(t ; c'est donc des flottants 31 bits
(:opvaxn #$9C #$8F #$F1 :arg1 #$50) ; rotl -$15, :arg1, r0
(:opvaxn #$9C #$8F #$F1 :arg2 #$51) ; rotl -$15, :arg2, r1
(:opvaxn #$51 #$50 #$51))) ; cmpf r0 r1
(:vxcondbr 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.
; Si <lab> est pre'sent, branchement a` <lab> si la valeur retourne'e
; par la fonction est = a` 0, sinon si <lab> = (), chargement de la
; valeur de tretour dans :arg2.
(:opvaxn #$DD :arg2) ; pushl \2
(:opvaxn #$DF #$AF) ; pushal (pc)+B↑d .... re'sol en fin
(let ((pc (copy :PCcurrent))
(:localstack (add :localstack 2)))
(:1byte 0) ; sera re'solu a` la fin.
(:opvaxn #$DD :arg1) ; pushl \1
(:opvaxgofvalq 'JMP fnt) ; jmp <fnt>
(memory pc (sub1 (subadr :PCcurrent pc))))
(ifn lab
(:opvaxn #$D0 #$8E :arg2) ; popl \2
(:opvaxn #$D0 #$8E #$50) ; popl r0 (et position indic)
(:vxcondbr #$12 lab)))
(de :macflotop (op fnt)
; ope'ration nume'rique flottante.
(if (not :31bitfloats)
(:generatecall2subr fnt ())
(:opvaxn #$D0 #$8F #$0 #$0 #$1 #$0 #$5B) ; movl 0x10000, r11
(:opvaxn #$9C #$8F #$F1 :arg1 #$50) ; rotl -$15, :arg1, r0
(:opvaxn #$CA #$5B #$50) ; bicl2 r11 r0
(:opvaxn #$9C #$8F #$F1 :arg2 #$51) ; rotl -$15, :arg2, r1
(:opvaxn #$CA #$5B #$51) ; bicl2 r11 r1
(:1byte op) ; <op>f2
(:opvaxn #$50 #$51) ; r0,r1
(:opvaxn #$C8 #$5B #$51) ; bisl2 r11 r1
(:opvaxn #$9C 15 #$51 :arg2))) ; rotl $15, r1, :arg2
;.Section "Les fonctions de chargement des ope'randes"
; .SSection "L'ope'rande VAX ge'ne'rique"
(de :opvax (op)
; charge l'ope'rande VAX <op>
(cond
((eq op 'nil)
; ope'rande nil (en fait ||)
(:1byte #$58))
((eq op 'A1)
; accu Le←Lisp
(:1byte #$52))
((eq op 'A2)
; accu Le←Lisp
(:1byte #$53))
((eq op 'A3)
; accu Le←Lisp
(:1byte #$54))
((eq op 'A4)
; accu Le←Lisp
(:1byte #$55))
((memq op '(LLINK DLINK ITCOUNT CBINDN TAG LOCK PROT))
(if (memq op '(LLINK DLINK ITCOUNT))
; Ce sont des mots me'moire.
(:1byte #$9F)
; Les autres sont des adresses immediates. @cbindn.
(:1byte #$8F) )
(:1long (symeval (symbol 'llcp op))))
((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 "OPVAX" op)))
((eq (car op) 'quote)
; une constante lisp imme'diate
(unless (or (and :31bitfloats (floatp (cadr op)))
(fixp (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) (addadr :PCcurrent 1))
(:add-llitt (cadr op)))))
(if (and (fixp (cadr op))
(le (cadr op) 63)
(ge (cadr op) 0))
; adressage imme'diat court
(:1byte (cadr op))
; adressage imme'diat long
(:1byte #$8F) ; (pc)+
(:1long (loc (cadr op)))))
((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 "OPVAX@" op))
((eq (car op) '&)
; (& <n>) Le nie`me pointeur de la pile
(if (or (not (fixp (cadr op))) (lt (cadr op) 0))
(:error "OPVAX" op)
(let ((n (add (cadr op) :localstack)))
(cond
((eq n 0) (:1byte #$6E))
((lt n 32) (:1byte #$AE) (:1byte (mul 4 n)))
(t (:1byte #$CE) (:1word (mul 4 n)))))))
((memq (car op) '(CAR VAL CVAL))
; adressage indirect simple
(:1byte (selectq (cadr op)
(A1 #$62)
(A2 #$63)
(A3 #$64)
(A4 #$65)
(t (:error "OPVAX" op)))))
((memq (car op) '(CDR PLIST FVAL PKGC OVAL ALINK PNAME TYP))
; adressage indirect indexe'
(:1byte (selectq (cadr op)
(A1 #$A2)
(A2 #$A3)
(A3 #$A4)
(A4 #$A5)
(t (:error "OPVAX" op))))
(:1byte (selectq (car op)
((cdr typ) 4)
(plist 4)
(fval 8)
(pkgc 12)
(oval 16)
(alink 20)
(pname 28)
(t (:error "OPVAX" op)))))
((eq (car op) 'CVALQ)
; la C-valeur Lisp d'un symbole
(ifn (symbolp (cadr op))
(:error "OPVAX" op)
(:opvaxquotesymb (cadr op))))
((eq (car op) 'FVALQ)
; la C-valeur Lisp d'un symbole
(ifn (symbolp (cadr op))
(:error "OPVAX" op)
(:opvaxfvalq (cadr op))))
((eq (car op) 'EVAL)
; Pour calculer des ope'randes a` load time.
(catcherror t (:opvax (eval (cadr op)))) )
(t (if (and (symbolp (car op))
(setq :f (getfn1 'ld-ind (car op))))
(funcall :f op)
(:error "OPVAX" op)))))
; .SSection "Ope'rande pouvant e↑tre sur 16 bits."
(de :opvax-word (op)
(ifn (:fixp op)
; C'est une ope'rande classique.
(:opvax op)
; Sinon on ne charge qu'au plus 16 bits.
(let ((n (cadr op)))
(if (and (le n 63) (ge n 0))
(:1byte n) ; Imme'diat 6 bits.
(:1byte #$8F) ; (pc)+
(:1word n) )))) ; Imme'diat 16 bits.
; .SSection "Ope'rande pouvant e↑tre sur 8 bits."
(de :opvax-byte (op)
(ifn (:fixp op)
; C'est une ope'rande classique.
(:opvax op)
; Sinon on ne charge qu'au plus 8 bits.
(let ((n (cadr op)))
(if (and (le n 63) (ge n 0))
(:1byte n) ; Imme'diat 6 bits.
(:1byte #$8F) ; (pc)+
(:1byte n) )))) ; Imme'diat 8 bits.
; .SSection "Appel multiple de OPVAX ou 1BYTE"
(dmd :opvaxn l
; appels multiples de :1byte ou :opvax
`(progn ,@(mapcar (lambda (l)
(if (fixp l) `(:1byte ,l) `(:opvax ,l)))
l)))
; .SSection "Ope'rande de type adresse de symbole Lisp"
(de :opvaxquotesymb (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))
(if (and (fixp :valaux) (ge :valaux 0))
(if (lt :valaux 126)
(progn (:1byte #$A8) ; (r8)B↑d
(:1byte :valaux)) ; 8 1ers symboles
(progn (:1byte #$C8) ; (r8)W↑d
(:1word :valaux))) ; 1024 1ers symboles
(progn (:1byte #$E8) ; (r8)L↑d
(:1long :valaux)))) ; tous les autres symb
; .SSection "Ope'rande indeirect indeexe'"
(de :opvaxi (short long depl)
; charge un ope'rande indirect indexe
; si le depl est < 8 bits utilise short sinin long
(if (< depl 128)
(progn (:1byte short) (:1byte depl))
(progn (:1byte long) (:1word depl))))
; .Section "Gestion des e'tiquettes"
; .SSection "Les e'tiquettes globales (JCALL/JMP)"
(de :opvaxfvalq (symb)
; charge un ope'rande de type "fval de symbole"
; <symb> est toujours un symbole
(setq :valaux (subadr (loc symb) :locnil))
(cond ((and (fixp :valaux) (gt :valaux 0))
; chouette 1 des 1000 1er symboles :
(:1byte #$C8) ; (r8)W↑d, BSYMB=r8
(:1word (add :valaux 8)))
(t ; too bad, depl sur 32 bits
(:1byte #$E8) ; (r8)L↑d, BSYMB=r8
(:1long (addadr :valaux 8)))))
(de :opvaxgofvalq (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))
(fixp (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
; ?!?!? bug : si l'on fait -3 le test FIXP est insuffisant ?!?!
(cond ((:check8 :valaux)
; cas brb/bsbb avec byte displ
(:1byte (if (eq type 'JMP) #$11 #$10))
(:1byte (sub (logand #$FF :valaux) 2)))
(t ; cas brw/bsbw avec word displ
(:1byte (if (eq type 'JMP) #$31 #$30))
(:1word (sub :valaux 3)))))
(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!
(:1byte (if (eq type 'JMP) #$17 #$16)) ; JMP/JSB op
(setq :valaux (subadr (loc symb) :locnil))
(cond ((and (fixp :valaux) (gt :valaux 0))
; chouette 1 des 1000 1er symboles :
(:1byte #$D8) ; (r8)W↑d, BSYMB=r8
(:1word (add :valaux 8)))
(t ; too bad, depl sur 32 bits
(:1byte #$F8) ; (r8)L↑d, BSYMB=r8
(:1long (addadr :valaux 8)))))
(:opvaxfvalq symb))))
; .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)))
; .SSection "Les e'tiquettes locales BRA/CALL sur 8/16 bits"
(de :brarel (byte word adr)
; engendre un appel de BRA/CALL sur 8 ou 16 bits
; ?!?! ERREUR si un module > 64k (cf ENTRY) ?!?!?
(setq :valaux (:valadrel adr))
(cond
((:check8 :valaux)
(:1byte byte)
(:1byte (sub (logand #$FF :valaux) 2)))
((:check16 :valaux)
; Branchement en arrie`re de 16 bits.
(ifn (and (fixp :valaux) (le :valaux 0))
; C'est plus que 15 bits
(:error "Module trop gros" :module)
(:1byte word)
(:1word (sub :valaux 3))))
((:notoofar adr :lobj)
(:1byte byte)
(:addlabel adr 8 0)
(:1byte 0))
(t ; connais pas encore
(:1byte word)
(if (and (symbolp adr) (null (assq adr :llabels)))
; dans les ENTRY
(:addentry adr)
; dans les LOCAL
(:addlabel adr 16 0))
(:1byte 0)
(:1byte 0))))
; .SSection "Branchements conditionnels locaux"
(de :vxcondbr (code adr)
; charge le code <code> de branchement conditionnel vers <adr>.
; L'e'tiquette <adr> est toujours locale. Pour utiliser
; un de'placement sur 8 bits, il faut e↑tre de;'ja` de'fini
; ou bien n'e↑tre pas trop loin sinon il faut inverser la condition.
(cond
((:check8 (setq :valaux (:valadrel adr)))
(:1byte code)
(:1byte (sub (logand #$FF :valaux) 2)))
((:notoofar adr :lobj)
(:1byte code)
(:addlabel adr 8 0)
(:1byte 0))
(t ; la` c'est vraiment trop loin ...
; inversion du test EQ <-> NEQ GTR <-> LE
(:1byte (selectq code
(#$13 #$12)
(#$12 #$13)
(#$14 #$15)
(#$15 #$14)
(#$18 #$19)
(#$19 #$18)
(#$1A #$1B)
(#$1B #$1A)
(t (:error "VXCONDBR" (list code adr)))))
(:1byte 3)
(:brarel #$11 #$31 adr))))
; .SSection "Calcul d'un de'placement relatif a` PC sur 8/16 bits"
(dmd :opvaxshortad (op)
; (pc)+B↑d ou (pc)+W↑d op (cf BRA)
`(:brarel #$AF #$CF ,op))
;.Section "Les fonctions auxiliaires de chargement me'moire"
;.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 :align ()
; aligne le compteur de chargement sur une
; frontie`re de mots de 32 bits (merci VAX)
(until (eq (logand 3 (if (fixp :PCcurrent)
:PCcurrent
(cdr :PCcurrent)))
0)
(:1byte 1))) ; charge un NOP!
;.SSection "chargement d'1 seul mot de 16 bits"
(de :1word (obj)
; charge 1 mot obj : attention a` l'ordre, inverse
; de celui du PDP11, MC68000 ...
(:1byte (logand obj #$FF))
(:1byte (logand (logshift obj -8) #$FF)))
(de :1wordrelPC (adr corr)
; charge le de'placement relatif a` PCcurrent pour l'adresse adr
; avec une correction de corr.
(setq :valaux (add (sub (subadr :PCcurrent adr) 2) corr))
(unless (and (fixp :valaux) (ge :valaux 0))
(:error "Module trop gros" :module) )
(memory adr (logand #$FF :valaux))
(memory (incradr adr 1) (logand #$FF (logshift :valaux -8))))
; .SSSection "Chargement par paquet de 32 bits"
(de :1long (val)
; charge la valeur <val> sur 32 bits
(cond ((fixp val)
(:1word val)
(:1byte 0)
(:1byte 0))
((consp val)
(:1word (cdr val))
(:1word (car val)))
(t (:error "1LONG" val))))
; .Section "Fonctions de gestion des tables d'e'tiquettes"
(de :notoofar (adr lobj)
; Le VAX n'ayant que des branchements conditionnels sur 8 bits,
; les branchements avant utilisent une heuristique :
; l'e'tiquette doit e↑tre a` moins de 12 instructions LAP
; avec une correction pour les instructions tres longues.
(tag ok
(let ((count 12)
e)
(while (and (gt count 0) (consp lobj))
(nextl lobj e)
(cond ((atom e)
(when (eq e adr) (exit ok t)))
((eq (car e) 'BRX)
(setq count (sub count
(div (length (cadr e)) 4))))
((memq (car e) '(HBXMOV HBMOVX HPXMOV HPMOVX
FPLUS FDIFF FTIMES FQUO))
(setq count (sub count 3)))
(t (setq count (sub1 count)))))
())))
(de :addlabel (sym depl corr)
; 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) et
; une correction (petit entier) de <corr>
; retourne 0 (adresse inconnue)
(setq :valaux (assq sym :llabels-nr))
(if :valaux
(rplacd :valaux (cons (cons (cons depl (copylist :PCcurrent))
corr)
(cdr :valaux)))
(newl :llabels-nr (list sym (cons (cons depl (copylist :PCcurrent))
corr))))
0)
(de :addentry (sym)
; 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))
(if :valaux
(rplacd :valaux (cons (copylist :PCcurrent) (cdr :valaux)))
(newl :entries-not-resolved (list sym (copylist :PCcurrent))))
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 debbug"
(de memory-dump (adr n)
; dump la memoire en hexa de <adr> sur <n> mots
; attention au SWAB du VAX! 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
:localstack ; ?!?!?!?!?!?
:valaux ; itou pour des valeurs locales.
:f ; itou (pour des getfn1)
(:nwl 0) ; itou pour tabler le code produit.
:local-cons-llitt)
; 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
(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 'ldvax) ))