Return to util.l CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / liszt

Annotation of 43BSDReno/pgrm/lisp/liszt/util.l, revision 1.1

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file util
        !             3:    "$Header: util.l,v 1.15 87/12/15 17:09:21 sklower Exp $")
        !             4: 
        !             5: ;;; ----       u t i l                 general utility functions
        !             6: ;;;
        !             7: ;;;                            -[Tue Aug 16 17:17:32 1983 by layer]-
        !             8: 
        !             9: 
        !            10: ;--- d-handlecc :: handle g-cc
        !            11: ; at this point the Z condition code has been set up and if g-cc is
        !            12: ; non nil, we must jump on condition to the label given in g-cc
        !            13: ;
        !            14: (defun d-handlecc nil
        !            15:    (if (car g-cc)
        !            16:        then (e-gotot (car g-cc))
        !            17:     elseif (cdr g-cc)
        !            18:        then (e-gotonil (cdr g-cc))))
        !            19: 
        !            20: ;--- d-invert :: handle inverted condition codes
        !            21: ; this routine is called if a result has just be computed which alters
        !            22: ; the condition codes such that Z=1 if the result is t, and Z=0 if the
        !            23: ; result is nil (this is the reverse of the usual sense).  The purpose
        !            24: ; of this routine is to handle g-cc and g-loc.  That is if g-loc is 
        !            25: ; specified, we must convert the value of the Z bit of the condition 
        !            26: ; code to t or nil and store that in g-loc.  After handling g-loc we
        !            27: ; must handle g-cc, that is if the part of g-cc is non nil which matches
        !            28: ; the inverse of the current condition code, we must jump to that.
        !            29: ;
        !            30: (defun d-invert nil
        !            31:   (if (null g-loc) 
        !            32:       then (if (car g-cc) then (e-gotonil (car g-cc))
        !            33:            elseif (cdr g-cc) then  (e-gotot (cdr g-cc)))
        !            34:       else (let ((lab1 (d-genlab))
        !            35:                 (lab2 (if (cdr g-cc) thenret else (d-genlab))))
        !            36:                (e-gotonil lab1)
        !            37:                ; Z=1, but remember that this implies nil due to inversion
        !            38:                (d-move 'Nil g-loc)
        !            39:                (e-goto lab2)
        !            40:                (e-label lab1)
        !            41:                ; Z=0, which means t
        !            42:                (d-move 'T g-loc)
        !            43:                (if (car g-cc) then (e-goto (car g-cc)))
        !            44:                (if (null (cdr g-cc)) then (e-label lab2)))))
        !            45:                        
        !            46: ;--- d-noninvert :: handle g-cc and g-loc assuming cc non inverted
        !            47: ; 
        !            48: ; like d-invert except Z=0 implies nil, and Z=1 implies t
        !            49: ;
        !            50: (defun d-noninvert nil
        !            51:   (if (null g-loc) 
        !            52:       then (if (car g-cc) then (e-gotot (car g-cc))
        !            53:            elseif (cdr g-cc) then  (e-gotonil (cdr g-cc)))
        !            54:       else (let ((lab1 (d-genlab))
        !            55:                 (lab2 (if (cdr g-cc) thenret else (d-genlab))))
        !            56:                (e-gotot lab1)
        !            57:                ; Z=0, this implies nil
        !            58:                (d-move 'Nil g-loc)
        !            59:                (e-goto lab2)
        !            60:                (e-label lab1)
        !            61:                ; Z=1, which means t
        !            62:                (d-move 'T g-loc)
        !            63:                (if (car g-cc) then (e-goto (car g-cc)))
        !            64:                (if (null (cdr g-cc)) then (e-label lab2)))))
        !            65: 
        !            66: ;--- d-macroexpand :: macro expand a form as much as possible
        !            67: ;
        !            68: ; only macro expands the top level though.
        !            69: (defun d-macroexpand (i)
        !            70:    (prog (first type)
        !            71:       loop
        !            72:       (if (and (dtpr i) (symbolp (setq first (car i))))
        !            73:         then (if (eq 'macro (setq type (d-functyp first 'macro-ok)))
        !            74:                 then (setq i (apply first i))
        !            75:                      (go loop)
        !            76:               elseif (eq 'cmacro type)
        !            77:                 then (setq i (apply (get first 'cmacro) i))
        !            78:                      (go loop)))
        !            79:       (return i)))
        !            80: 
        !            81: ;--- d-fullmacroexpand :: macro expand down all levels
        !            82: ; this is not always possible to due since it is not always clear
        !            83: ; if a function is a lambda or nlambda, and there are lots of special
        !            84: ; forms.  This is just a first shot at such a function, this should
        !            85: ; be improved upon.
        !            86: ;
        !            87: (defun d-fullmacroexpand (form)
        !            88:    (if (not (dtpr form))
        !            89:        then form
        !            90:        else (setq form (d-macroexpand form))   ; do one level
        !            91:             (if (and (dtpr form) (symbolp (car form)))
        !            92:                then (let ((func (getd (car form))))
        !            93:                          (if (or (and (bcdp func)
        !            94:                                       (eq 'lambda (getdisc func)))
        !            95:                                  (and (dtpr func)
        !            96:                                       (memq (car func) '(lambda lexpr)))
        !            97:                                  (memq (car form) '(or and)))
        !            98:                              then `(,(car form)
        !            99:                                      ,@(mapcar 'd-fullmacroexpand
        !           100:                                                (cdr form)))
        !           101:                            elseif (eq (car form) 'setq)
        !           102:                              then (d-setqexpand form)
        !           103:                            else form))
        !           104:                else form)))
        !           105: 
        !           106: ;--- d-setqexpand :: macro expand a setq statemant
        !           107: ; a setq is unusual in that alternate values are macroexpanded.
        !           108: ;
        !           109: (defun d-setqexpand (form)
        !           110:    (if (oddp (length (cdr form)))
        !           111:        then (comp-err "wrong number of args to setq " form)
        !           112:        else (do ((xx (reverse (cdr form)) (cddr xx))
        !           113:                 (res))
        !           114:                ((null xx) (cons 'setq res))
        !           115:                (setq res `(,(cadr xx)
        !           116:                             ,(d-fullmacroexpand (car xx))
        !           117:                             ,@res)))))
        !           118:    
        !           119: ;--- d-typesimp ::  determine the type of the argument 
        !           120: ;
        !           121: #+(or for-vax for-tahoe)
        !           122: (defun d-typesimp (arg val)
        !           123:   (let ((argloc (d-simple arg)))
        !           124:        (if (null argloc)
        !           125:            then (let ((g-loc 'reg)
        !           126:                       g-cc g-ret)
        !           127:                     (d-exp arg))
        !           128:                 (setq argloc 'reg))
        !           129:        #+for-vax (e-write4 'ashl '$-9 (e-cvt argloc) 'r0)
        !           130:        #+for-tahoe (e-write4 'shar '$9 (e-cvt argloc) 'r0)
        !           131:        (e-write3 'cmpb '"_typetable+1[r0]" val)
        !           132:        (d-invert)))
        !           133: 
        !           134: #+for-68k
        !           135: (defun d-typesimp (arg val)
        !           136:    (let ((argloc (d-simple arg)))
        !           137:        (if (null argloc)
        !           138:           then (let ((g-loc 'reg)
        !           139:                      g-cc g-ret)
        !           140:                    (d-exp arg))
        !           141:                (setq argloc 'reg)
        !           142:           else (e-move (e-cvt argloc) 'd0))
        !           143:        (e-sub '#.nil-reg 'd0)
        !           144:        (e-write3 'moveq '($ 9) 'd1)
        !           145:        (e-write3 'asrl 'd1 'd0)
        !           146:        (e-write3 'lea '"_typetable+1" 'a5)
        !           147:        (e-write3 'cmpb val '(% 0 a5 d0))
        !           148:        (d-invert)))
        !           149: 
        !           150: ;--- d-typecmplx  :: determine if arg has one of many types
        !           151: ;      - arg : lcode argument to be evaluated and checked
        !           152: ;      - vals : fixnum with a bit in position n if we are to check type n
        !           153: ;
        !           154: #+(or for-vax for-tahoe)
        !           155: (defun d-typecmplx (arg vals)
        !           156:   (let ((argloc (d-simple arg))
        !           157:        (reg))
        !           158:        (if (null argloc) then (let ((g-loc 'reg)
        !           159:                                    g-cc g-ret)
        !           160:                                   (d-exp arg))
        !           161:                              (setq argloc 'reg))
        !           162:        (setq reg 'r0)
        !           163:        #+for-vax (e-write4 'ashl '$-9 (e-cvt argloc) reg)
        !           164:        #+for-tahoe (e-write4 'shar '$9 (e-cvt argloc) reg)
        !           165:        (e-write3 'cvtbl (concat "_typetable+1[" reg "]") reg)
        !           166:        (e-write4 #+for-vax 'ashl #+for-tahoe 'shal reg '$1 reg)
        !           167:        (e-write3 'bitw vals reg)
        !           168:        (d-noninvert)))
        !           169: 
        !           170: #+for-68k
        !           171: (defun d-typecmplx (arg vals)
        !           172:    (let ((argloc (d-simple arg))
        !           173:         (l1 (d-genlab))
        !           174:         (l2 (d-genlab)))
        !           175:        (makecomment '(d-typecmplx: type check))
        !           176:        (if (null argloc)
        !           177:           then (let ((g-loc 'reg)
        !           178:                      g-cc g-ret)
        !           179:                    (d-exp arg))
        !           180:                (setq argloc 'reg)
        !           181:           else (e-move (e-cvt argloc) 'd0))
        !           182:        (e-sub '#.nil-reg 'd0)
        !           183:        (e-write3 'moveq '($ 9) 'd1)
        !           184:        (e-write3 'asrl 'd1 'd0)
        !           185:        (e-write3 'lea '"_typetable+1" 'a5)
        !           186:        (e-add 'd0 'a5)
        !           187:        (e-write3 'movb '(0 a5) 'd0)
        !           188:        (e-write2 'extw 'd0)
        !           189:        (e-write2 'extl 'd0)
        !           190:        (e-write3 'moveq '($ 1) 'd1)
        !           191:        (e-write3 'asll 'd0 'd1)
        !           192:        (e-move 'd1 'd0)
        !           193:        (e-write3 'andw vals 'd0)
        !           194:        (d-noninvert)
        !           195:        (makecomment '(d-typecmplx: end))))
        !           196: 
        !           197: ;---- register handling routines.
        !           198: 
        !           199: ;--- d-allocreg :: allocate a register 
        !           200: ;  name - the name of the register to allocate or nil if we should
        !           201: ;        allocate the least recently used.
        !           202: ;
        !           203: (defun d-allocreg (name)
        !           204:   (if name 
        !           205:       then (let ((av (assoc name g-reguse)))
        !           206:                (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
        !           207:                name)
        !           208:       else ; find smallest used count
        !           209:           (do ((small (car g-reguse))
        !           210:                (smc (cadar g-reguse))
        !           211:                (lis (cdr g-reguse) (cdr lis)))
        !           212:               ((null lis)
        !           213:                (rplaca (cdr small) (1+ smc))
        !           214:                (car small))
        !           215:               (if (< (cadar lis) smc)
        !           216:                   then (setq small (car lis)
        !           217:                              smc   (cadr small))))))
        !           218: 
        !           219: 
        !           220: ;--- d-bestreg :: determine the register which is closest to what we have
        !           221: ;  name - name of variable whose subcontents we want
        !           222: ;  pat  - list of d's and a's which tell which part we want
        !           223: ;
        !           224: (defun d-bestreg (name pat)
        !           225:   (do ((ll g-reguse (cdr ll))
        !           226:        (val)
        !           227:        (best)
        !           228:        (tmp)
        !           229:        (bestv -1))
        !           230:       ((null ll)
        !           231:        (if best
        !           232:           then (rplaca (cdr best) (1+ (cadr best)))
        !           233:                (list (car best)
        !           234:                      (if (> bestv 0) 
        !           235:                          then (rplacd (nthcdr (1- bestv)
        !           236:                                               (setq tmp
        !           237:                                                     (copy pat)))
        !           238:                                       nil)
        !           239:                               tmp
        !           240:                          else nil)
        !           241:                      (nthcdr bestv pat))))
        !           242:       (if (and (setq val (cddar ll))
        !           243:               (eq name (car val)))
        !           244:          then (if (> (setq tmp (d-matchcnt pat (cdr val)))
        !           245:                      bestv)
        !           246:                   then (setq bestv tmp
        !           247:                              best  (car ll))))))
        !           248: 
        !           249: ;--- d-matchcnt :: determine how many parts of a pattern match
        !           250: ; want - pattern we want to achieve
        !           251: ; have - pattern whose value exists in a register
        !           252: ; 
        !           253: ; we return a count of the number of parts of the pattern match.
        !           254: ; If this pattern will be any help at all, we return a value from 
        !           255: ; 0 to the length of the pattern.
        !           256: ; If this pattern will not work at all, we return a number smaller
        !           257: ; than -1.  
        !           258: ; For `have' to be useful for `want', `have' must be a substring of 
        !           259: ; `want'.  If it is a substring, we return the length of `have'.
        !           260: ; 
        !           261: (defun d-matchcnt (want have)
        !           262:   (let ((length 0))
        !           263:        (if (do ((hh have (cdr hh))
        !           264:                (ww want (cdr ww)))
        !           265:               ((null hh) t)
        !           266:               (if (or (null ww) (not (eq (car ww) (car hh))))
        !           267:                   then (return nil)
        !           268:                   else (incr length)))
        !           269:           then  length
        !           270:           else  -2)))
        !           271: 
        !           272: ;--- d-clearreg :: clear all values in registers or just one
        !           273: ; if no args are given, clear all registers.
        !           274: ; if an arg is given, clear that register
        !           275: ;
        !           276: (defun d-clearreg n
        !           277:   (cond ((zerop n) 
        !           278:         (mapc '(lambda (x) (rplaca (cdr x) 0)
        !           279:                     (rplacd (cdr x) nil))
        !           280:               g-reguse))
        !           281:        (t (let ((av (assoc (arg 1) g-reguse)))
        !           282:                (if av
        !           283:                   then
        !           284:                        #+for-68k (d-regused (car av))
        !           285:                        (rplaca (cdr av) 0)
        !           286:                        (rplacd (cdr av) nil)
        !           287:                   else nil)))))
        !           288: 
        !           289: ;--- d-clearuse :: clear all register which reference a given variable
        !           290: ;
        !           291: (defun d-clearuse (varib)
        !           292:   (mapc '(lambda (x)
        !           293:                 (if (eq (caddr x) varib) then (rplacd (cdr x) nil)))
        !           294:        g-reguse))
        !           295: 
        !           296: ;--- d-inreg :: declare that a value is in a register
        !           297: ; name - register name
        !           298: ; value - value in a register
        !           299: ;
        !           300: (defun d-inreg (name value)
        !           301:   (let ((av (assoc name g-reguse)))
        !           302:        (if av then (rplacd (cdr av) value))
        !           303:        name))
        !           304: 
        !           305: (defun e-setup-np-lbot nil
        !           306:    (e-move '#.np-reg '#.np-sym)
        !           307:    (e-move '#.lbot-reg '#.lbot-sym))
        !           308: 
        !           309: ;---------------MC68000 only routines
        !           310: #+for-68k
        !           311: (progn 'compile
        !           312: 
        !           313: ;--- d-regtype :: find out what type of register the operand goes
        !           314: ;                in.
        !           315: ; eiadr - an EIADR
        !           316: ;
        !           317: (defun d-regtype (eiadr)
        !           318:    (if (symbolp eiadr)
        !           319:        then (if (memq eiadr '(d0 d1 d2 d3 d4 d5 d6 d7 reg)) then 'd
        !           320:             elseif (memq eiadr '(a0 a1 a2 a3 a4 a5 a6 a7 sp areg)) then 'a)
        !           321:     elseif (or (eq '\# (car eiadr))
        !           322:               (eq '$ (car eiadr))
        !           323:               (and (eq '* (car eiadr))
        !           324:                    (eq '\# (cadr eiadr))))
        !           325:        then 'd
        !           326:        else 'a))
        !           327: 
        !           328: ;--- d-regused :: declare that a reg is used in a function
        !           329: ;      regname - name of the register that is going to be used
        !           330: ;                (ie, 'd0 'a2...)
        !           331: ;
        !           332: (defun d-regused (regname)
        !           333:    (let ((regnum (diff (cadr (exploden regname)) 48))
        !           334:         (regtype (car (explode regname))))
        !           335:        (if (memq regname '(a0 a1 d0 d1))
        !           336:           thenret
        !           337:        elseif (equal 'd regtype)
        !           338:           then (rplacx regnum g-regmaskvec t) regname
        !           339:           else (rplacx (plus regnum 8) g-regmaskvec t) regname)))
        !           340: 
        !           341: ;--- d-makemask :: make register mask for moveml instr
        !           342: ;
        !           343: (defun d-makemask ()
        !           344:    (do ((ii 0 (1+ ii))
        !           345:        (mask 0))
        !           346:        ((greaterp ii 15) mask)
        !           347:        (if (cxr ii g-regmaskvec)
        !           348:           then (setq mask (plus mask (expt 2 ii))))))
        !           349: 
        !           350: ;--- init-regmaskvec :: initalize hunk structure to all default
        !           351: ;                      save mask.
        !           352: ;
        !           353: ; nil means don't save it, and t means save the register upon function entry.
        !           354: ; order in vector: d0 .. d7, a0 .. a7.
        !           355: ; d3 : lbot (if $global-reg$ is t then save)
        !           356: ; d7 : _nilatom
        !           357: ; a2 : _np
        !           358: ; a3 : literal table ptr
        !           359: ; a4 : old _lbot (if $global-reg$ is t don't save)
        !           360: ; a5 : intermediate address calc
        !           361: ;
        !           362: (defun init-regmaskvec ()
        !           363:    (setq g-regmaskvec
        !           364:         (makhunk
        !           365:             (if $global-reg$
        !           366:                 then (quote (nil nil nil t   nil nil nil t
        !           367:                              nil nil t   t   t   t   nil nil))
        !           368:                 else (quote (nil nil nil nil nil nil nil t
        !           369:                              nil nil t   t   t   t   nil nil))))))
        !           370: 
        !           371: ;--- Cstackspace :: calc local space on C stack
        !           372: ; space = 4 * (no. of register variables saved on stack)
        !           373: ;
        !           374: (defun Cstackspace ()
        !           375:    (do ((ii 0 (1+ ii))
        !           376:        (retval 0))
        !           377:        ((greaterp ii 15) (* 4 retval))
        !           378:        (if (cxr ii g-regmaskvec) then (setq retval (1+ retval)))))
        !           379: 
        !           380: ;--- d-alloc-register :: allocate a register
        !           381: ;  type - type of register (a or d)
        !           382: ;  name - the name of the register to allocate or nil if we should
        !           383: ;        allocate the least recently used.
        !           384: ;
        !           385: (defun d-alloc-register (type name)
        !           386:    (if name 
        !           387:        then (let ((av (assoc name g-reguse)))
        !           388:                (d-regused name)
        !           389:                (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
        !           390:                name)
        !           391:        else ; find smallest used count
        !           392:            (let ((reguse))
        !           393:                (do ((cur g-reguse (cdr cur)))
        !           394:                    ((null cur))
        !           395:                    (if (eq type (car (explode (caar cur))))
        !           396:                        then (setq reguse (cons (car cur) reguse))))
        !           397:                (do ((small (car reguse))
        !           398:                     (smc (cadar reguse))
        !           399:                     (lis (cdr reguse) (cdr lis)))
        !           400:                    ((null lis)
        !           401:                     (rplaca (cdr small) (1+ smc))
        !           402:                     (d-regused (car small))
        !           403:                     (car small))
        !           404:                    (if (< (cadar lis) smc)
        !           405:                        then (setq small (car lis)
        !           406:                                   smc   (cadr small)))))))
        !           407: 
        !           408: ); end 68000 only routines

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.