; .EnTete "Le-Lisp (c) version 15.2" " " "Le chargeur me'moire Multics"
; .EnPied " " "%" " "
; .SuperTitre "Le chargeur me'moire Multics"
;
; .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: lapmultics.ll,v 4.1 88/01/13 12:20:49 kuczynsk Rel $"
; VERSION MULTISEGMENT et MONO
; ce fichier a e'te' e'crit en prenant pour mode`le lap68k
(unless (>= (version) 15.2)
(error 'load 'erricf 'lapmultics))
(setq #:sys-package:colon 'ld)
; mono ou multi segment ???
(unless (boundp '#:ld:mono)
(print "Mono ou multi segment ??? (mono=T multi=NIL)")
(setq #:ld:mono (with ((inchan ())) (read))))
(defvar :mono :mono)
;---------------------------------------------
; Les variables globales
(add-feature 'loader)
(defvar :ecode (subadr (#:system:ecode) 64))
(unless (boundp ':pccurrent)(defvar :pccurrent) ())
(defvar :pccurrent :pccurrent) ; simplifier la vie au compilo
(defvar :obase (obase)) ; la base initiale
(defvar :obj ()) ; l'instruction a charger
; verifier que toutes les fonctions son OK (indiquees par TMP)
;(defvar :esymb '(high . 0))
;(defvar :evect '(high . 1))
;(defvar :tmp '(high . 2))
;(defvar :NIL '(high . 3)) ; idem bsymb
;(defvar :bsymb '(high . 3))
;(defvar :efloat '(high . 4))
;(defvar :bfloat '(high . 5))
;(defvar :bvar '(high . 6))
(defvar :special-case-loader ()) ;cas special pour charger le chargeur
(defvar :lentries ())
(defvar :lentries-nr (list ())) ; un cons bidon
(defvar :llabels-nr (list ())) ; idem
(defvar :talkp ())
(defvar :llabels () )
(defvar :fntname () )
(defvar :module () )
(defvar :saved-by-loader ())
(unless (boundp ':global-saved-by-loader)
(defvar :global-saved-by-loader
'(#[:talkp :pccurrent :llabels :llabels-nr
:lentries-nr :fntname])))
;
;-------------------------------------------------------------------
; Des fonctions pour faire marcher le systeme
(defsharp o ()
(with ((ibase 8))
(let ((r (read)))
(if (numberp r)
(list r)
(syserror '|#o| 'errsxt r)))))
; Les tests de type
(dmd :registre? (a)
`(:getr ,a))
(de :getr (r) (cassq r '(
(a1 . 1) (a2 . 2) (a3 . 3) (a4 . 4) (x0 . 0) (x6 . 6)(x7 . 7)
(nil . 7) (x5 . 5) (au . #o15) (qu . #o16) )))
(de :number? (x)
(and (consp x) (eq (car x) 'quote) (numberp (cadr x))))
(de :llm3-arg (:arg) ; evalue les eval s'il y en a
(if (and (consp :arg) (eq (car :arg) 'eval))
(car (catcherror t (eval (cadr :arg))))
:arg)))
(de :type? (o)
(if (atom o)
(cond ((numberp o) ':adresse?)
((:registre? o) ':registre?)
((memq o '(llink dlink)) ':memoire?)
(t ':adresse?))
(selectq (car o)
(quote ':immediat?) ; peut-etre un nombre
(@ ':adresse?)
(cvalq ':memoire?)
(& ':pile?)
(t
(if (:registre? (cadr o))
(if (cdr (cassoc (car o) :acces-list)) ':high? ':low?)
(:error 'type←inconnu o))))))
(dmd :get-ind (r)
`(car (cassq ,r :acces-list)))
(dmd :highp (r)
`(cdr (cassq ,r :acces-list)))
(defvar :acces-list
'((car 0 . t) (cdr 0 . () ) (cval 0 . t) (pkgc 2 . t)(pname 3 . ())
; (ftype 3 . t)(ptype 3 . ())
; pas d'acces ftype et ptype GAFFE
(plist 0 . () ) (fval 1 . t) (oval 2 . ())) ))
(dmd :entry? (x)
`(if (memq ,x '(subr0 subr1 subr2 subr3 nsubr fsubr msubr dmsubr))
,x
(:error "ENTRY" ,x)))
(dmd :cpfun? (fun)
`(memq (typefn ,fun) '(subr0 subr1 subr2 subr3 nsubr fsubr msubr dmsubr)))
;---------------------------------------------------------------------
;
; Interpretation d'un objet
(de :ins ()
; charge un objet (instruction ou pseudo) en me'moire
(cond
((null :obj) ())
((atom :obj) ; etiquette locale, ajoute et solve
(newl :llabels (cons :obj (copylist :pccurrent)))
(:solve1 :obj :llabels-nr))
((eq (car :obj) 'eval) (catcherror t (eval (cadr :obj))))
((:ins1 (car :obj)
(:llm3-arg (cadr :obj))
(:llm3-arg (caddr :obj))
(:llm3-arg (cadddr :obj))))
((getfn1 ':ld-codop (car :obj))
(apply (getfn1 ':ld-codop (car :obj)) :obj))
(t (:error "opcode inconnu" (car :obj))))))
(de :ins1 (opcode :\1 :\2 :\3)
(selectq opcode
(abort t)
(endl
(when :talkp (terpri))
(:check-solve :llabels-nr t)
t)
(end
(:check-solve :llabels-nr t)
(:check-solve :lentries-nr ())
(while :lentries (:rem-prop (nextl :lentries)))
(:special-case-loader)
(:clean-llitt)
t)
(entry
(newl :lentries (list :\1 :\2 :\3)) ; (entry? :\2)
(:solve1 :\1 :lentries-nr)
(putprop :\1 (copylist :pccurrent) ':fval)
(setq :fntname :\1))
(fentry
(when :talkp (terpri))
(let ((aux (copylist :pccurrent)))
(if :special-case-loader
(progn
(newl :special-case-loader (list :\1 :\2 aux))
(putprop :\1 aux ':fval))
(newl :lentries (list :\1 :\2 :\3))
(setfn :\1 :\2 aux))
(setq :fntname :\1)))
(local
(newl :llabels (ncons :\1)))
(title
(setq :module :\1))
(t (:machins opcode :\1 :\2 :\3))))
; les machins machine-dependants
(de :machins (opcode :\1 :\2 :\3)
(let ((ok t))
(selectq
opcode
(btnil
(:compare-nil :\1) (:tra←rel #o600 :\2)) ; [tze \2]
(bfnil
(:compare-nil :\1) (:tra←rel #o601 :\2)) ; [tnz \2]
(btcons
(:compare-h 0 :\1) (:tra←rel #o603 :\2)) ; [trc \2] ESYMB
(bfcons
(:compare-h 0 :\1) (:tra←rel #o602 :\2)) ; [tnc \2] ESYMB
(btfix
(:compare-h 5 :\1) (:tra←rel #o602 :\2)) ; [tnc \2] BFLOAT
(bffix
(:compare-h 5 :\1) (:tra←rel #o603 :\2)) ; [trc \2] BFLOAT
(btfloat
(:btxxx 5 4 :\1)(:tra←rel #o602 :\2)) ; tnc BFLOAT EFLOAT
(btstrg
(:btxxx 1 3 :\1)(:tra←rel #o602 :\2)) ; tnc EVECT ESTRG
(btvect
(:btxxx 4 1 :\1)(:tra←rel #o602 :\2)) ; tnc EFLOAT EVECT
(btsymb
(:btxxx 3 0 :\1)(:tra←rel #o602 :\2)) ; tnc ESTRG ESYMB
(btvar
(:btxxx 6 0 :\1)(:tra←rel #o602 :\2)) ; tnc BVAR ESYMB
(bfsymb
;ICI
(:bfxxx 3 0 :\1 :\2)) ; ESTRG ESYMB
(bfvect
(:bfxxx 4 1 :\1 :\2)) ; EFLOAT EVECT
(bfstrg
(:bfxxx 1 3 :\1 :\2)) ; EVECT ESTRG
(bffloat
(:bfxxx 5 4 :\1 :\2)) ; BFLOAT EFLOAT
(bfvar
(:bfxxx 6 0 :\1 :\2)) ; BVAR ESYMB
((cabeq cnbeq)
(:compare-eq :\1 :\2)(:tra←rel #o600 :\3)); [tze \3]
((cabne cnbne)
(:compare-eq :\1 :\2)(:tra←rel #o601 :\3)); [tnz \3]
(cnblt
(:btnxx :\1 :\2)(:tra←rel #o604 :\3)) ; [tmi \3]
(cnble
(:btnxx :\1 :\2)(:tra←rel←spec #o604 :\3)); [tmoz \3]
(cnbgt
(:btnxx :\1 :\2)(:tra←rel←spec #o605 :\3)); [tpnz \3]
(cnbge
(:btnxx :\1 :\2)(:tra←rel #o605 :\3)) ; [tpl \3]
(cfbeq
(:btfxx :\1 :\2)(:tra←rel #o600 :\3)) ; [tze \3]
(cfbne
(:btfxx :\1 :\2)(:tra←rel #o601 :\3)) ; [tnz \3]
(cfblt
(:btfxx :\1 :\2)(:tra←rel #o604 :\3)) ; [tmi \3]
(cfble
(:btfxx :\1 :\2)(:tra←rel←spec #o604 :\3)); [tmoz \3]
(cfbgt
(:btfxx :\1 :\2)(:tra←rel←spec #o605 :\3)); [tpnz \3]
(cfbge
(:btfxx :\1 :\2)(:tra←rel #o605 :\3)) ; [tpl \3]
(times
(:nb←to←q←et←tmp :\1 :\2)
(:load 2 #o402 0) ; [mpy TMP]
(:load 4 #o731 0) ; [ars 4]
(:load 0 #o636 5) ; [eaq 0,al] charge le res dans q
(:aqu←to←nb 'qu :\2)) ; et charge
(quo
(:nb←to←q←et←tmp :\1 :\2) ; premier nombre dans q
(:load 2 #o506 0) ; [div TMP]
(:load 18 #o736 0) ; [qls 18]
(:aqu←to←nb 'qu :\2)) ; et charge
(rem
(:nb←to←q←et←tmp :\1 :\2)
(:load 2 #o506 0) ; [div TMP]
(:load 2 #o731 0) ; [ars 2]
(:aqu←to←nb 'au :\2)) ; et charge
(fplus
(:op←flottant #o477 :\1 :\2)) ; [dfad]
(fdiff
(:op←flottant #o577 :\1 :\2)) ; [dfsb]
(ftimes
(:op←flottant #o463 :\1 :\2)) ; [dfmp]
(fquo
(:op←flottant #o567 :\1 :\2)) ; [dfdv]
(decr
(if (:registre? :\1)
(:decremente :\1) ; [eax\1 -1,\1] + masque
(:move-to-x0 :\1)
(:decremente 'x0) ; [eax0 -1,x0] + masque
(:move-x0 :\1)))
(incr
(if (:registre? :\1)
(:incremente :\1) ; [eax\1 1,\1] + masque
(:move-to-x0 :\1)
(:incremente 'x0) ; [eax0 1,x0] + masque
(:move-x0 :\1)))
(land
(if (:registre? :\2)
(:land :\1 :\2)
(:move-to-x0 :\2)
(:land :\1 'x0)
(:move-x0 :\2)))
(lor
(:clear-tmp)
(:move-to-tmp-x6 :\1)
(if (:registre? :\2)
(:orx :\2 2 'n) ;TMP
(:move-to-x0 :\2)
(:orx 'x0 2 'n) ;TMP
(:move-x0 :\2)))
(lxor
(:clear-tmp)
(:move-to-tmp-x6 :\1)
(if (:registre? :\2)
(:erx :\2 2 'n) ;TMP
(:move-to-x0 :\2)
(:erx 'x0 2 'n) ;TMP
(:move-x0 :\2)))
(lshift
(:shift :\1 :\2))
(negate
(if (:registre? :\1)
(:negate :\1)
(:move-to-x0 :\1)
(:negate 'x0)
(:move-x0 :\1)))
(plus
(if (:registre? :\2)
(:plus :\1 :\2)
(:move-to-x6 :\2)
(:plus :\1 'x6)
(:move-x6 :\2)))
(diff
(if (:registre? :\2)
(:diff :\1 :\2)
(:move-to-x6 :\2)
(:diff :\1 'x6)
(:move-x6 :\2)))
(adjstk
(if (:number? :\1)
(:eax 'x5 (:number :\1) 'x5)
(:move-to-pr0 :\1)
(:eax←pr0 'x5 0 'x5)))
(bra
(:tra←rel #o710 :\1)) ;[tra \1]
(bri
(if (:registre? :\1)
(:tra←reg :\1) ;[tra 0,\1]
(:move-to-x0 :\1)
(:tra←reg 'x0))) ;[tra 0,x0]
(brx
(if (:registre? :\2)
(:brx :\2)
(:move-to-x6 :\2)
(:brx 'x6))
(mapc ':arg :\1))
(call
(:decr 'x5)
(:call)
(:tra←rel #o710 :\1))
(car
(:ldx :\1 0 :\1))
(cdr
(:lxl :\1 0 :\1))
(hbmovx
(:load-heap :\2) ;dans pr0
(:move-to-tmp-x6 :\1)
(:move-to-x0 :\3)
(:load #o110 #o100 #o400) ; [mlr (),(pr,x0)]
(:load 2 #o200 1) ; [desc9a 2,1]
(:load 1 0 1)) ; [desc9a pr0|0(1),1]
(hbxmov
(:clear-tmp)
(:load-heap :\1)
(:move-to-x0 :\2)
(:load 0 #o100 #o510) ; [mlr (pr,x0),()]
(:load 1 0 1) ; [desc9a pr0|0(1),1]
(:load 2 #o200 1) ; [desc9a 2,1]
(:move-tmp :\3))
(hgsize
(if (:registre? :\1) ; 1 charge le vecteur
(:ldx 'x0 0 :\1)
(:move-to-x0 :\1)
(:ldx 'x0 0 'x0))
(if (:registre? :\2) ; 2 acces au heap
(:load←heap :\2 0 'x0)
(:load←heap 'x0 0 'x0)
(:move-x0 :\2)))
(hpmovx
(:load-heap :\2)
(let ((a1 :\1)(a2 :\3))
(unless (:registre? :\1)(:move-to-x0 :\1)(setq a1 'x0))
(unless (:registre? :\3)(:move-to-x6 :\3)(setq a2 'x6))
(:stx←pr0 a1 1 a2)))
(hpxmov
(:load-heap :\1)
(let ((a1 :\2)(a2))
(unless (:registre? :\2)(:move-to-x0 :\2)(setq a1 'x0))
(setq a2 (if (:registre? :\3) :\3 'x6))
(:ldx←pr0 a2 1 a1)
(unless (:registre? :\3)(:move-x6 :\3))))
(jcall
(:decr 'x5)
(:tra :\1 t)) ; t pour stocker ic+2 dans la pile
(jmp
(:tra :\1 ())) ; () pour ne rien stocker
(mov
(:move :\1 :\2))
(movnil
(:move-reg 'x7 :\1))
(movxsp
(:epp0←pr2 0 'x5)
(let ((a1 :\1)(a2 :\2))
(unless (:registre? :\1)(:move-to-x0 :\1)(setq a1 'x0))
(unless (:registre? :\2)(:move-to-x6 :\2)(setq a2 'x6))
(:stx←pr0 a1 0 a2)))
(nop
(:load 0 #o11 0)) ; [nop 0]
(pop
(:incr 'x5) ; a mon avis mettre le incr apres c'est mieux
(if (:registre? :\1)
(:load←heap :\1 '(3 . -1) 'x5)
(:load←heap 'x0 '(3 . -1) 'x5)
(:move-x0 :\1)))
(push
(if (:registre? :\1) ; meme commentaire que push
(:sto←heap :\1 '(3 . -1) 'x5)
(:move-to-x0 :\1)
(:sto←heap 'x0 '(3 . -1) 'x5))
(:decr 'x5))
(return
(:return))
(sobgez ;decremente arg; si c'est encore >=0 branchement
(let ((aux :\1))
(unless (:registre? :\1)(setq aux 'x6)(:move-to-x6 :\1))
(:decremente aux) ; decremente
(unless (eq aux :\1) (:move-x6 :\1)) ; avant le test
(:cmpxi aux #o100000) ; comp avec :\1 ou x6
(:tra←rel #o602 :\2))) ; [tnc \2]
(sobgtz ; decremente arg; si c'est encore >0 branchement
(let ((aux :\1))
(unless (:registre? :\1)(setq aux 'x6)(:move-to-x6 :\1))
(:decremente aux)
(unless (eq aux :\1) (:move-x6 :\1)) ; avant le test
(:cmpxi aux 0) ; [cmpx\1 0,du]
(:load 3 #o600 4) ; [tze 3,ic]
(:cmpxi aux #o100000) ; [cmpx\1 #$8000]
(:tra←rel #o602 :\2))) ; [tnc \2]
(sstack
(:move-to-reg :\1 'x5))
(stack
(:move-reg 'x5 :\1))
(xspmov
(:epp0←pr2 0 'x5)
(if (:registre? :\1)
(:xspmov :\1 :\2)
(:move-to-x6 :\1)
(:xspmov 'x6 :\2)))
(t (setq ok ())))
ok))
(de :xspmov (arg1 arg2)
(if (:registre? arg2)
(:ldx←pr0 arg2 0 arg1)
(:ldx←pr0 'x0 0 arg1)
(:move-x0 arg2)))
(de :nb←to←q←et←tmp (nb1 nb2)
(:move-to-aq nb1 'qu)
(:load 2 #o736 0) ; [qls 2]
(:load 2 #o756 0) ; [stq TMP]
(:move-to-aq nb2 'qu)
(:load 2 #o736 0)) ; [qls 2]
(de :aqu←to←nb (source but) ;source = au ou qu
(:mask source)
(if (:registre? but)
(:eax but 0 source)
(:eax 'x0 0 source)
(:move-x0 but)))
(de :land (arg1 arg2)
(if (:number? arg1)
(:anx arg2 (cadr arg1) 'du)
(:clear-tmp)
(:move-to-tmp-x6 arg1)
(:anx arg2 2 'n))) ;TMP
(de :negate (aux)
(:eax 'au 0 aux)
(:neg)
(:eax aux 0 'au)
(:mask aux))
(de :plus (arg1 arg2)
(if (:number? arg1)
(:eax arg2 (:number arg1) arg2)
(:move-to-pr0 arg1)
(:eax←pr0 arg2 0 arg2))
(:mask arg2)))
(de :diff (arg1 arg2)
(if (:number? arg1)
(:eax arg2 (:neg-number arg1) arg2)
(if (:registre? arg1)
(:eax 'au 0 arg1)
(:move-to-x0 arg1)
(:eax 'au 0 'x0))
(:neg)
(:epp0 0 'au)
(:eax←pr0 arg2 0 arg2))
(:mask arg2))
(de :brx (arg)
(:epp0 3 'ic) ; ATTENTION a ce 3
(:eax←pr0 'x0 0 arg) ; IC+1
(:tra←reg 'x0) ; IC+2 [tra 0,x0]
) ; et commence a IC+3
;-------------------------------------------------------------------
;
; Les fonctions de chargement
; 1) la fonction load
(de :load (adr opcode tag)
(when :talkp (:print-load adr opcode tag))
(memoryh :pccurrent adr)
(memoryl :pccurrent opcode tag)
(setq :pccurrent (incradr :pccurrent 1))))
; 2) les fonctions differentes en mono et multi
(de :compare (reg adr tag)
(:load adr (add #o100 (:getr reg)) (:tag←val tag)))
(de :compare-stack (reg adr tag)
(:load-with-heap adr (add #o100 (:getr reg)) (:tag←val tag)))))
(de :load←heap (reg adr tag)
(:load-with-heap adr (add #o220 (:getr reg)) (:tag←val tag)))
(de :sto←heap (reg adr tag)
(:load-with-heap adr (add #o740 (:getr reg)) (:tag←val tag)))
;SEUL MONO existant dans le code
(de :load-with-heap (adr reg tag)
(if :mono (:load adr reg tag)
(:load (:add←pr 2 adr) reg (add #o100 tag)))))
(de :epp0←pr2(adr tag) (:load-with-heap adr #o350 (:tag←val tag)))
(de :return () (:load 7 #o710 0))
;[ldx0 stack|-1,x5][tra 0,x0]
(de :call () (:load-with-heap 0 #o750 #o15)) ; [stc2 stack|0,x5]
(de :opflo (op reg) (:load 0 op (:tag←val reg)))
; 3 les fonctions avec des registres
(de :epp0 (adr tag) (:load adr #o350 (:tag←val tag)))))
(de :cmpxi (reg adr) (:load adr (add #o100 (:getr reg)) 3)) ;cmpx ,du
(de :cmpxn (reg adr) (:load adr (add #o100 (:getr reg)) 0)) ;cmpx ,n
(de :ldx (reg adr tag) (:load adr (add #o220 (:getr reg)) (:tag←val tag))))))
(de :lxl (reg adr tag) (:load adr (add #o720 (:getr reg)) (:tag←val tag))))))
(de :sxl (reg adr tag) (:load adr (add #o440 (:getr reg)) (:tag←val tag))))))
(de :orx (reg adr tag) (:load adr (add #o260 (:getr reg)) (:tag←val tag))))))
(de :anx (reg adr tag) (:load adr (add #o360 (:getr reg)) (:tag←val tag))))))
(de :eax (reg adr tag) (:load adr (add #o620 (:getr reg)) (:tag←val tag))))))
(de :erx (reg adr tag) (:load adr (add #o660 (:getr reg)) (:tag←val tag))))))
(de :stx (reg adr tag) (:load adr (add #o740 (:getr reg)) (:tag←val tag))))))
(de :incr (x) (:eax x 1 x))
(de :clear-tmp ()(:load 2 #o450 0)) ; [stz TMP]
(de :neg () (:load 0 #o531 0)) ; [neg 0]
(de :arg (adr) (:load (:adr-rel(cadr adr)) #o710 4)); [tra \1-*,ic]
(de :decremente (reg)(:decr reg)(:mask reg))
(de :incremente (reg)(:incr reg)(:mask reg))
(de :mask (reg) (:anx reg -1 'du)) ; [anx\1 =o177777,du]
(de :decr (reg) (:eax reg '(3 . -1) reg)) ; [eax\1 -1,\1]
(de :tra←ind (adr) (:load adr #o710 #o51)))) ; [tra \1,i]
(de :tra←reg (reg) (:load 0 #o710 (:tag←val reg))) ; [tra 0,\1]
; 4) des fonctions avec pr0
(de :stx←pr0 (reg adr tag) ;[stx\1 pr0|\2,\3]
(:load (:15-bits adr) (add #o740 (:getr reg))(add #o100 (:tag←val tag)))))
(de :eax←pr0 (reg adr tag) ;[eax\1 pr0|\2,\3]
(:load (:15-bits adr) (add #o620 (:getr reg))(add #o100 (:tag←val tag)))))
(de :ldx←pr0 (reg adr tag) ;[ldx\1 pr0|\2,\3]
(:load (:15-bits adr) (add #o220 (:getr reg)) (add #o100(:tag←val tag))))))
(de :15-bits (nb) ; teste si l'adresse tient sur 15 bits pour les PRS
(cond ((and (fixp nb) (plusp nb)) nb)
((and (consp nb) (eq (car nb) 0) (plusp (cadr nb))) (cadr nb))
((and (consp nb) (eq (car nb) 3) (minusp (cdr nb)))
(logand (cdr nb) #o77777))
(t (:error ':15-bits nb))))
(de :add←pr (pr adr)
(setq adr (:15-bits adr))
(selectq pr
(0 adr)
(1 (logor adr #o100000))
(2 (cons 1 adr))
(t (:error "registre pointeur invalide" pr))))
; 5) les fonctions de transfert
(de :tra←rel (tra adr) (:load (:adr-rel adr) tra 4))
(de :tra←rel←spec (tra adr)
(:load (:adr-rel adr) tra #o404))
; 6) les fonctions qui recuperent les valeurs
(de :tag←val (tag)
(cassq tag
'((n . 0)
(au . 1)
(qu . 2)
(du . 3)
(ic . 4)
; (al . 5) ; ne sert pas
; (ql . 6) ; ne sert pas
(dl . 7)
(x0 . 8)
(a1 . 9)
(a2 . 10)
(a3 . 11)
(a4 . 12)
(x5 . 13)
(x6 . 14)
(nil . 15)
(x7 . 15))))
;--------------------------------------------------------------------------
;
; Des fonctions un peu compliquees
(de :shift (circ arg)
(:load 0 #o636 0) ; [eaq 0] nettoie q
(:move-to-aq arg 'qu) ; charge le nombre dans q
(cond ((:number? circ) ; miracle c'est un entier
(setq circ (cadr circ)) ; prend la valeur
(if (> circ 0) ; test du signe
(:load circ #o736 0) ; [qls circ] on y va
(:load (- circ)#o772 0))) ; [qrl -circ]
(t ; c'est plus complique.
(:load 0 #o635 0) ; [eaa 0] nettoie a
(:move-to-aq circ 'au) ; y met circ
(:cmpxi 'au #o100000) ; [cmpa =o100000,du] quel signe ?
(:load 5 #o602 4) ; [tnc 5,ic]
(:neg) ; prend l'oppose
(:mask 'au) ; masque un peu
(:load 0 #o772 1) ; [qrl 0,au]
(:load 2 #o710 4) ; [tra 2,ic] et saute le reste
(:load 0 #o736 1))) ; [qls 0,au]
(:mask 'qu) ; masque le resultat
(if (:registre? arg) ; type du resultat ?
(:eax arg 0 'qu) ; facile si registre
(:eax 'x0 0 'qu) ; sinon met dans x0
(:move-x0 arg)))))) ; et deplace
; le move simple
(de :move (source but)
(if (eq source 'nil)
(:move-reg 'x7 but)
(if (:registre? but)
(:move-to-reg source but)
(if (:registre? source)
(:move-reg source but)
(:move-to-x0 source)
(:move-x0 but)))))
; move dans un registre
(de :move-to-reg (source but)
(selectq (:type? source)
(:registre? (:eax but 0 source)) ;
(:immediat? (:eax but (:ival source) 'n)) ; ??
(:memoire? (:load-m source but))
(:pile? (:load←heap but (:pval source) 'x5))
(:high? (:ldx but (:get-ind (car source)) (cadr source)))
(:low? (:lxl but (:get-ind (car source)) (cadr source)))
(:adresse?
(if (consp source)
(:eax but (:adr-rel (cadr source)) 'ic)
(:eax but (:fval1 source) 'n)))
(t
(:error 'move (list source but))))))))
(de :load-m (source but)
(:ldx but (:mval source) 'n))
(de :move-reg (source but)
(selectq (:type? but)
(:registre? (:eax but 0 source))
(:memoire? (:sto-m source but))
(:pile? (:sto←heap source (:pval but) 'x5))
(:high? (:stx source (:get-ind (car but)) (cadr but)))
(:low? (:sxl source (:get-ind (car but)) (cadr but)))
(t (:error 'move (list source but))))))))
(de :sto-m (source but)
(:stx source (:mval but) 'n))
(de :move-to-aq (source dest) ; dest est un faux registre !!!
(if (:registre? source)
(:eax dest 0 source)
(:move-to-x0 source)
(:eax dest 0 'x0)))
(de :move-to-x0 (x) (:move-to-reg x 'x0))
(de :move-x0 (x)(:move-reg 'x0 x))
(de :move-to-x6 (x) (:move-to-reg x 'x6))
(de :move-x6 (x)(:move-reg 'x6 x))
(de :move-to-pr0 (arg)
(if (:registre? arg)
(:epp0 0 arg)
(:move-to-x0 arg)
(:epp0 0 'x0)))
(de :move-signed (op reg) ; extension du signe, reg est un registre
(if (:number? op) ; immediat ?
(if (plusp (setq op (cadr op))) ; positif ?
(:eax reg op 'n) ; OK
(:eax reg (cons 3 op) 'n)) ; les bits de signe
(:move-to-reg op reg) ; commence par mettre tel quel
(:cmpxi reg #o100000) ; le signe ??
(:load 2 #o602 4) ; tnc 2,ic si positif skip
(:orx reg '(3 . 0) 'du))))) ; le bit de signe
;------------------------------------------------------------
; Les fonctions de comparaison
(de :btxxx (bzone ezone arg) ; si bzone <= arg < ezone transfert
(unless (:registre? arg)(:move-to-x0 arg)(setq arg 'x0))
(:cmpxn arg bzone)
(:load 3 #o602 4) ; tnc 3,ic
(:cmpxn arg ezone))
(de :bfxxx (bzone ezone arg label) ;si NON(bzone <= arg < ezone) transfert
(unless (:registre? arg) (:move-to-x0 arg)(setq arg 'x0))
(:cmpxn arg bzone)
(:tra←rel #o602 label)
(:cmpxn arg ezone)
(:tra←rel #o603 label))
(de :btnxx (nb1 nb2) ; prepare la comparaison de deux nombres
(:move-signed nb1 'x0)
(:move-signed nb2 'x6)
(:stx 'x6 2 'n) ;TMP
(:cmpxn 'x0 2)) ;TMP
(de :opflo1 (opcode fl)
(if (:registre? fl)
(:opflo opcode fl)
(:move-to-x0 fl)
(:opflo opcode 'x0)))
(de :btfxx (fl1 fl2)
(:opflo1 #o433 fl1) ; dfld
(:opflo1 #o517 fl2)) ; dfcmp
(de :op←flottant (mnemo fl1 fl2)
(:alloc←fl) ; le flottant est dans x6
(:opflo1 #o433 fl2) ; [dfld] charge le deuxieme flottant
(:move-x6 fl2) ; sauve le resultat
(:opflo1 mnemo fl1) ; fait l'operation
(:opflo #o457 'x6)) ; [dfst] stocke le resultat
(de :alloc←fl () ;jcall #:llcp:alloc←float, positionne x6
(:decr 'x5)
(:tra '#:llcp:alloc←float t))
; des hacks pour commencer
; pour les CABEQ change l'ordre si meilleur
(de :compare-eq (arg1 arg2)
(if (memq (:type? arg1) '(:immediat? :memoire? :high?))
(:compare←ok arg2 arg1) ;pas besoin de tmp
(:compare←ok arg1 arg2)))))))
(de :compare-nil (arg)
(if (:registre? arg)
(:cmpxn arg 3) ; NIL
(:compare←ok1 'x7 arg)))
(de :compare-h (zone valeur)
(if (:registre? valeur)
(:cmpxn valeur zone)
(:move-to-x0 valeur)
(:cmpxn 'x0 zone)))
(de :compare←ok (a b)
(if (:registre? a)
(:compare←ok1 a b)
(:move-to-x0 a)
(:compare←ok1 'x0 b)))
(de :compare←ok1 (a b)
(selectq (:type? b)
(:registre? (:stx b 2 'n) ; b dans tmp TMP
(:cmpxn a 2)) ; idem high TMP
(:immediat? (:cmpxi a (:ival b))) ; ok
(:memoire? (:compare-m a b))
(:pile? (:compare-stack a (:pval b) 'x5))
(:high? (:compare a (:get-ind (car b))(cadr b)))
(:low? (:move-to-tmp-x6 b) (:cmpxn a 2)) ;TMP
(t
(:error 'compare (list a b)))))))))))))))))
(de :compare-m (a b)
(:cmpxn a (:mval b)))
(de :move-to-tmp-x6 (arg)
(if (:registre? arg)
(:stx arg 2 'n) ;TMP
(:move-to-x6 arg)
(:stx 'x6 2 'n))) ;TMP
(de :move-tmp (arg)
(if (:registre? arg)
(:ldx arg 2 'n) ;TMP
(:ldx 'x0 2 'n) ;TMP
(:move-x0 arg)))
(de :load-heap (arg)
(if (:registre? arg)
(:ldx 'x0 0 arg)
(:move-to-x0 arg)
(:ldx 'x0 0 'x0))
(:epp0←pr2 0 'x0)))))
;←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←
;
; Resolution des etiquettes locales
(de :valadr (adr) ;calcule une adresse absolue
(if (atom adr)
(cond ((cassq adr :llabels)) ; etiquette resolue
((and (symbolp adr)(getprop adr ':fval))) ; fonction chargee
((and (symbolp adr)(:cpfun? adr))(valfn adr))
(t ()))
(if (and (fixp (car adr))(fixp (cdr adr)))
adr
(:error 'valadr adr))))))
(de :adr-rel (adr) ;calcule une adresse relative
(let ((aux (:valadr adr)))
(if aux
(subadr aux :pccurrent)
(:add-label1 adr (copylist :pccurrent)
(if (symbolp adr) :lentries-nr :llabels-nr))
0)))
(de :tra (adr call) ; jmp et jcall
(when call (:call))
(:add-llitt adr)
(let ((aux))
(if (setq aux (cassq adr :llabels)) ; c'est local !!!
(:load (subadr aux :pccurrent) #o710 4)
(:tra←ind (addadr 1 (loc adr))))))
; la gestion des etiquettes non resolues
(de :add-label1 (obj adr liste)
(let ((aux (assq obj liste)))
(if aux
(rplacd aux (cons adr (cdr aux)))
(rplacd liste (cons (list obj adr) (cdr liste))))))))))
(de :rem-prop (x)
(setq x (car x))
(remprop x ':fval)
(remprop x '#:llcp:fval)
(remprop x '#:llcp:ftype)
(remprop x '#:llcp:larg)
(remprop x '#:system:loaded-from-file)))))))
(de :clean-llitt ()
(setq :saved-by-loader (cons () :saved-by-loader))
(let ((l :saved-by-loader)
(i -1)
(lit )
v)
(while (consp (cdr l))
(setq lit (cadr l))
(if (and (symbolp lit)
(or (boundp lit)
(typefn lit)))
(rplacd l (cddr l))
(setq l (cdr l))))
(setq :saved-by-loader (cdr :saved-by-loader))
(when :saved-by-loader
(setq v (makevector (length :saved-by-loader) ()))
(while :saved-by-loader
(vset v (setq i (add1 i)) (nextl :saved-by-loader)))
(if :module
(putprop :module v ':saved-by-loader)
(newl :global-saved-by-loader v)))
(setq :module ())))))
(de :check-solve (x flag)
(if (cdr x)
(:error (if flag "il reste des references locales non resolues"
"il reste des ENTRY non resolues")
(cdr x))
t))
(de :special-case-loader ()
(let ((arg))
(while (consp :special-case-loader)
(nextl :special-case-loader arg)
(:rem-prop arg)
(setfn (car arg) (cadr arg) (caddr arg)))))))
(de :add-llitt (obj)
(or (memq obj :saved-by-loader) (newl :saved-by-loader obj)))
(de :solve1 (objet liste)
(mapc ':solve (cassq objet liste))
(delete (assq objet liste) liste)))
(de :solve (val)
(when :talkp (:prin-solve val))
(memoryh val (subadr :pccurrent val))))
; les fonctions qui impriment un operande
; et qui verifient si c'est bien declare
(dmd :pval (x) `(cadr ,x))
(dmd :neg-number (x)
`(sub 0 (cadr ,x))))
(de :number (x)
(setq x (cadr x))
(if (lt x 0)(cons 3 x) x))))
(de :mval (x)
(if (symbolp x) ;llink dlink dans #:llcp:llink il y a l'adresse
(or (cassq x :mval-list) (:error 'mval x))
(setq x (cadr x))
(:add-llitt x)
(loc x)))
; est-ce que le symeval est bien utile ???
(defvar :mval-list
(list (cons 'llink (symeval '#:llcp:llink))
(cons 'dlink (symeval '#:llcp:dlink))))
(defvar :fval-list
(list (cons 'cbindn (symeval '#:llcp:cbindn))
(cons 'tag (symeval '#:llcp:tag))
(cons 'prot (symeval '#:llcp:prot))
(cons 'lock (symeval '#:llcp:lock))))))
(de :ival ((quote x))
(unless (fixp x) (:add-llitt x))
(loc x))
(de :fval1 (x)
(or (and (symbolp x) (cassq x :fval-list)) (:error 'fval1 x)))))
;----- Fonction d'impression octale
(de :print-source (ins adr) ; appele pour chaque instruction
(when (consp ins) (outpos 4))
(prin ins)
(when (ge (outpos) 30)(terpri)))
(de :print-load (adr opcode tag)
(obase 8)
(outpos 30)
(:prinoct :pccurrent) (prin " ")
(:prinoct adr)(:prinoctb opcode)(:prinoctb tag)
(outpos 55)
(ifn (eq (logand #o400 tag) #o400)
(:opcode-en-clair opcode)
(prin (if (eq opcode #o604) 'tmoz 'tpnz)))
(outpos 62)
(:adr-en-clair adr tag)
(:tag-en-clair tag)
(terpri)
(obase :obase))
(de :opcode-en-clair (opcode)
(let ((aux (vref :opcode-en-clair (logshift opcode -4))))
(cond ((and aux (symbolp aux) (eq 0 (logand opcode 8)))
(prin aux (logand opcode 7))) ;cas sxl lxl
((and (stringp aux) (eq 0 (logand opcode 8)))
(prin aux "x" (logand opcode 7)))
((and (stringp aux) (eq 5 (logand opcode 7)))
(prin aux "a"))
((and (stringp aux) (eq 6 (logand opcode 7)))
(prin aux "q"))
((and (stringp aux) (eq 7 (logand opcode 7))
(neq opcode #o637) (neq #o40 (logand opcode #o60)))
(prin aux "aq"))
(t (prin (or (vref :opcode-reste opcode) "..."))))))))
(de :adr-en-clair (adr tag)
(if (eq 0 (logand tag #o100)) ; y a un PR ?
(:prinoct←nozero adr)
(prin "pr" (:pr-val adr) "|")
(if (consp adr)
(:prin-15bits (cdr adr))
(:prin-15bits adr))))
(de :prinoct (n)
; imprime sur 6 chiffres octal le nb ou l'adresse n
(if (fixp n)
(progn (:prinoctb (logshift n -9))
(:prinoctb1 n))
(unless (and (fixp (car n))(fixp (cdr n)))
(:error "prinoct l'argument n'est pas une adresse" n))
(:prinoctb (logor (logshift (car n) 7)(logshift (cdr n) -9)))
(:prinoctb1 (cdr n)))))
(de :prinoctb (n)
; imprime sur 3 chiffres octal le nb n
(when (lt n #o10)(princn #/0))
(when (lt n #o100)(princn #/0))
(prin n))
(de :prinoctb1 (n) ;imprime sur 3 chiffres les 3 derniers chiffres de n
(:prinoctb (logand n #o777)))
(de :pr-val1 (x)
(if (lt x 0) 1 0))
(de :pr-val (x)
(if (consp x)(+ (car x)(car x)(:pr-val1 (cdr x))) (:pr-val1 x)))))
(de :prin-15bits (n)
(setq n (logand n #o77777))
(if (lt n #o60000)(prin n)(prin "-" (logand (- n) #o37777)))))
(de :prinoct←nozero (n)
;imprime en octal avec signe, sans les zeros en trop (sur 18 bits)
(if (fixp n)
(:prinoct1 n)
(if (equal n '(3 . 0))
(prin "600000") ; mieux que -0 !!!!
(selectq (car n)
(0 (:prinoct1 (cdr n)))
(1 (:prinoct2 (cdr n)))
(2 (prin "-") (:prinoct2 (- (cdr n))))
(3 (prin "-") (:prinoct1 (- (cdr n))))
(t (:error 'prinoct←nozero n))))))
(de :prinoct1 (n) ; imprime le moins de chiffres possibles
(if (plusp n)
(prin n)
(prin (logshift n -9))
(:prinoctb1 n)))
(de :prinoct2 (n)
(prin (logor #o200 (logshift n -9)))
(:prinoctb1 n))
(de :tag-en-clair (tag)
(:tag-en-clair1 (logand tag #o77))
(unless (eq 0 (logand tag #o200))(prin ", INTOFF")))
(de :tag-en-clair1 (tag)
(let ((aux (logand tag #o60)))
(if (eq 0 aux)
(unless (eq 0 tag) (prin "," (vref :tag-en-clair tag)))
(setq tag (logand tag #o17))
(selectq aux
(#o20 (prin "," (vref :tag-en-clair tag) "*"))
(#o40 (prin "," (vref :special-tag tag)))
(#o60 (prin ",*" (vref :tag-en-clair tag)))))))))
(defvar :tag-en-clair
#["n" "au" "qu" "du" "ic" "al" "ql" "dl"
"x0" "x1" "x2" "x3" "x4" "x5" "x6" "x7"])
(defvar :special-tag
#["ft1" "itp" "002" "its" "sd" "scr" "ft2" "ft3"
"ci" "i" "sc" "ad" "di" "dic" "id" "idc"])
(defvar :opcode-en-clair
#[() "adl" "as" "ad" "cmp" "sbl" "ss" "sb"
"cna" "ld" "ors" "or" "can" "lc" "ans" "an"
() () sxl () () () () ()
() "ea" "ers" "er" () lxl "st" ()])
(defvar :opcode-reste
#[ () "mme" "drl" () "mme2" "mme3" () "mme4" () "nop" "puls1" "puls2" () "cioc" () ()
() () () () () () () () ()()"ldqc" "adl" "ldac" () () ()
() () () () () () () () "adwp0" "adwp1" "adwp2" "adwp3" "aos" ()()"sscr"
() () () () () () () () () "awca" "awcq" "lreg" () () () ()
() () () () () () () () () "cwl" () () () ()() ()
() () () () () () () () () () () () ()() () ()
() () () () () () () () "adwp4" "adwp5" "adwp6" "adwp7" "sdbr" () () ()
() () () () () () () () () "swca" "swcq" "lpri" () ()() ()
() () () () () () () () () "cmk" "absa" "epaq" "sznc" ()() ()
() () () () () () () () "lbar" "rsw" "ldbr" "rmcm" "szn" ()() ()
() () () () () () () () "spri0" "spbp1" "spri2" "spbp3" "spri" ()() "lsdp"
() () () () () () () () "tsp0" "tsp1" "tsp2" "tsp3" () () () ()
() () () () () () () () "eawp0" "easp0" "eawp2" "easp2" () () () ()
() () () () () () () () "eawp4" "easp4" "eawp6" "easp6" () () () ()
() () () () () () () () "epp0" "epbp1" "epp2" "epbp3" "stac" () () "stcd"
() () () () () () () () "epp4" "epbp5" "epp6" "epbp7" () () () ()
() "mpf" "mpy" () () "cmg" () () () "lde" () "rscr" () "ade" () ()
() "ufm" () "dufm" () "fcmg" () "dfcmg" "fszn" "fld" () "dfld" () "ufa" () "dufa"
() () () () () () () () "stz" "smic" "scpr" () "stt" "fst" "ste" "dfst"
() "fmp" () "dfmp" () () () () "fstr" "frd" "dfstr" "dfrd" () "fad" () "dfad"
"rpl" () () () () "bcd" "div" "dvf" () () () "fneg" () "fcmp" () "dfcmp"
"rpt" () () () () "fdi" () "dfdi"() "neg" "cams" "negl" () "ufs" ()"dufs"
"sprp0" "sprp1" "sprp2" "sprp3" "sprp4" "sprp5" "sprp6" "sprp7" "sbar" "stba" "stbq" "smcm" "stc1"
()() "ssdp"
"rpd" () () () () "fdv" () "dfdv" () () () "fno" () "fsb" () "dfsb"
"tze" "tnz" "tnc" "trc" "tmi" "tpl" () "ttf" "rtcd" () () "rcu" "teo" "teu" "dis" "tov"
() () () () () () () () "ret" () () "rccl" "ldi" () () "ldt"
() () () () () () () () "spri4" "spbp5" "spri6" "spbp7" "stacq" () () "scu"
() () () () () () () () "tsp4" "tsp5" "tsp6" "tsp7" "lcpr" () () ()
() () () () () () () () "tra" () () "call6" () "tss" "xec" "xed"
() () () () () () () () () "ars" "qrs" "lrs" () "als" "qls" "lls"
() () () () () () () () "stc2" "stca" "stcq" "sreg" "sti" () () ()
"lprp0" "lprp1" "lprp2" "lprp3" "lprp4" "lprp5" "lprp6" "lprp7" () "arl" "qrl" "lrl" "gtb" "alr" "qlr" "llr"])
(de :prin-solve (val)
(outpos 10)
(prin "solve a l'adresse: ")
(obase 8) (:prinoct val) (obase :obase)
(terpri)))
;----- Fonction auxiliaire d'erreur
(de :error (f a)
(obase :obase)
(terpri)
(print "***** LOADER : erreur durant le chargement de : " :fntname)
(print " type de l'erreur : " f)
(print " arguments de'fectueux : " a)
(print " instruction a charger : " :obj)
(exit :tagerr))
(de loaderesolve () (loader '(end)))
(de loader (:lobj . :talkp)
(when (consp :talkp)(setq :talkp (car :talkp)))
(let ((:pccurrent (#:system:ccode))
(:llabels)
(:obase (obase))
(:llabels-nr (list ()))
(:fntname 'loader))
(tag :tagerr
(while :lobj
(when (gtadr :pccurrent :ecode)
(error 'loader
"Plus de place"
:pccurrent))
(nextl :lobj :obj)
(when (and :talkp :obj)
(:print-source :obj :pccurrent))
(:ins))
(setq :obj '(endl))
(:ins)
(#:system:ccode :pccurrent))))))))
(unless (eq (typefn '#:llcp:nlist) 'subr0)
(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)
(mov a2 a3)
(mov 'errwna a2)
(jmp error)
(end))
t ))))
; pour complice,
; Toutes les fonctions du package ld sont des ENTRY, donc non redefinies
; on vire les definitions interpretees pour gagner de la place.
(unless (or (eq (typefn 'loaderesolve) 'expr)
(get 'loaderesolve 'resetfn))
(mapc
(lambda (m)
(when (typefn m)
(remfn m)
(remprop m '#:system:loaded-from-file) ))
(oblist 'ld)))))))))