Return to util.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / liszt

Annotation of 42BSD/ucb/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.14 83/08/28 17:13:11 layer 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: #+for-vax
        !           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:        (e-write4 'ashl '$-9 (e-cvt argloc) 'r0)
        !           130:        (e-write3 'cmpb '"_typetable+1[r0]" val)
        !           131:        (d-invert)))
        !           132: 
        !           133: #+for-68k
        !           134: (defun d-typesimp (arg val)
        !           135:    (let ((argloc (d-simple arg)))
        !           136:        (if (null argloc)
        !           137:           then (let ((g-loc 'reg)
        !           138:                      g-cc g-ret)
        !           139:                    (d-exp arg))
        !           140:                (setq argloc 'reg)
        !           141:           else (e-move (e-cvt argloc) 'd0))
        !           142:        (e-sub '#.nil-reg 'd0)
        !           143:        (e-write3 'moveq '($ 9) 'd1)
        !           144:        (e-write3 'asrl 'd1 'd0)
        !           145:        (e-write3 'lea '"_typetable+1" 'a5)
        !           146:        (e-write3 'cmpb val '(% 0 a5 d0))
        !           147:        (d-invert)))
        !           148: 
        !           149: ;--- d-typecmplx  :: determine if arg has one of many types
        !           150: ;      - arg : lcode argument to be evaluated and checked
        !           151: ;      - vals : fixnum with a bit in position n if we are to check type n
        !           152: ;
        !           153: #+for-vax
        !           154: (defun d-typecmplx (arg vals)
        !           155:   (let ((argloc (d-simple arg))
        !           156:        (reg))
        !           157:        (if (null argloc) then (let ((g-loc 'reg)
        !           158:                                    g-cc g-ret)
        !           159:                                   (d-exp arg))
        !           160:                              (setq argloc 'reg))
        !           161:        (setq reg 'r0)
        !           162:        (e-write4 'ashl '$-9 (e-cvt argloc) reg)
        !           163:        (e-write3 'cvtbl (concat "_typetable+1[" reg "]") reg)
        !           164:        (e-write4 'ashl reg '$1 reg)
        !           165:        (e-write3 'bitw vals reg)
        !           166:        (d-noninvert)))
        !           167: 
        !           168: #+for-68k
        !           169: (defun d-typecmplx (arg vals)
        !           170:    (let ((argloc (d-simple arg))
        !           171:         (l1 (d-genlab))
        !           172:         (l2 (d-genlab)))
        !           173:        (makecomment '(d-typecmplx: type check))
        !           174:        (if (null argloc)
        !           175:           then (let ((g-loc 'reg)
        !           176:                      g-cc g-ret)
        !           177:                    (d-exp arg))
        !           178:                (setq argloc 'reg)
        !           179:           else (e-move (e-cvt argloc) 'd0))
        !           180:        (e-sub '#.nil-reg 'd0)
        !           181:        (e-write3 'moveq '($ 9) 'd1)
        !           182:        (e-write3 'asrl 'd1 'd0)
        !           183:        (e-write3 'lea '"_typetable+1" 'a5)
        !           184:        (e-add 'd0 'a5)
        !           185:        (e-write3 'movb '(0 a5) 'd0)
        !           186:        (e-write2 'extw 'd0)
        !           187:        (e-write2 'extl 'd0)
        !           188:        (e-write3 'moveq '($ 1) 'd1)
        !           189:        (e-write3 'asll 'd0 'd1)
        !           190:        (e-move 'd1 'd0)
        !           191:        (e-write3 'andw vals 'd0)
        !           192:        (d-noninvert)
        !           193:        (makecomment '(d-typecmplx: end))))
        !           194: 
        !           195: ;---- register handling routines.
        !           196: 
        !           197: ;--- d-allocreg :: allocate a register 
        !           198: ;  name - the name of the register to allocate or nil if we should
        !           199: ;        allocate the least recently used.
        !           200: ;
        !           201: (defun d-allocreg (name)
        !           202:   (if name 
        !           203:       then (let ((av (assoc name g-reguse)))
        !           204:                (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
        !           205:                name)
        !           206:       else ; find smallest used count
        !           207:           (do ((small (car g-reguse))
        !           208:                (smc (cadar g-reguse))
        !           209:                (lis (cdr g-reguse) (cdr lis)))
        !           210:               ((null lis)
        !           211:                (rplaca (cdr small) (1+ smc))
        !           212:                (car small))
        !           213:               (if (< (cadar lis) smc)
        !           214:                   then (setq small (car lis)
        !           215:                              smc   (cadr small))))))
        !           216: 
        !           217: 
        !           218: ;--- d-bestreg :: determine the register which is closest to what we have
        !           219: ;  name - name of variable whose subcontents we want
        !           220: ;  pat  - list of d's and a's which tell which part we want
        !           221: ;
        !           222: (defun d-bestreg (name pat)
        !           223:   (do ((ll g-reguse (cdr ll))
        !           224:        (val)
        !           225:        (best)
        !           226:        (tmp)
        !           227:        (bestv -1))
        !           228:       ((null ll)
        !           229:        (if best
        !           230:           then (rplaca (cdr best) (1+ (cadr best)))
        !           231:                (list (car best)
        !           232:                      (if (> bestv 0) 
        !           233:                          then (rplacd (nthcdr (1- bestv)
        !           234:                                               (setq tmp
        !           235:                                                     (copy pat)))
        !           236:                                       nil)
        !           237:                               tmp
        !           238:                          else nil)
        !           239:                      (nthcdr bestv pat))))
        !           240:       (if (and (setq val (cddar ll))
        !           241:               (eq name (car val)))
        !           242:          then (if (> (setq tmp (d-matchcnt pat (cdr val)))
        !           243:                      bestv)
        !           244:                   then (setq bestv tmp
        !           245:                              best  (car ll))))))
        !           246: 
        !           247: ;--- d-matchcnt :: determine how many parts of a pattern match
        !           248: ; want - pattern we want to achieve
        !           249: ; have - pattern whose value exists in a register
        !           250: ; 
        !           251: ; we return a count of the number of parts of the pattern match.
        !           252: ; If this pattern will be any help at all, we return a value from 
        !           253: ; 0 to the length of the pattern.
        !           254: ; If this pattern will not work at all, we return a number smaller
        !           255: ; than -1.  
        !           256: ; For `have' to be useful for `want', `have' must be a substring of 
        !           257: ; `want'.  If it is a substring, we return the length of `have'.
        !           258: ; 
        !           259: (defun d-matchcnt (want have)
        !           260:   (let ((length 0))
        !           261:        (if (do ((hh have (cdr hh))
        !           262:                (ww want (cdr ww)))
        !           263:               ((null hh) t)
        !           264:               (if (or (null ww) (not (eq (car ww) (car hh))))
        !           265:                   then (return nil)
        !           266:                   else (incr length)))
        !           267:           then  length
        !           268:           else  -2)))
        !           269: 
        !           270: ;--- d-clearreg :: clear all values in registers or just one
        !           271: ; if no args are given, clear all registers.
        !           272: ; if an arg is given, clear that register
        !           273: ;
        !           274: (defun d-clearreg n
        !           275:   (cond ((zerop n) 
        !           276:         (mapc '(lambda (x) (rplaca (cdr x) 0)
        !           277:                     (rplacd (cdr x) nil))
        !           278:               g-reguse))
        !           279:        (t (let ((av (assoc (arg 1) g-reguse)))
        !           280:                (if av
        !           281:                   then
        !           282:                        #+for-68k (d-regused (car av))
        !           283:                        (rplaca (cdr av) 0)
        !           284:                        (rplacd (cdr av) nil)
        !           285:                   else nil)))))
        !           286: 
        !           287: ;--- d-clearuse :: clear all register which reference a given variable
        !           288: ;
        !           289: (defun d-clearuse (varib)
        !           290:   (mapc '(lambda (x)
        !           291:                 (if (eq (caddr x) varib) then (rplacd (cdr x) nil)))
        !           292:        g-reguse))
        !           293: 
        !           294: ;--- d-inreg :: declare that a value is in a register
        !           295: ; name - register name
        !           296: ; value - value in a register
        !           297: ;
        !           298: (defun d-inreg (name value)
        !           299:   (let ((av (assoc name g-reguse)))
        !           300:        (if av then (rplacd (cdr av) value))
        !           301:        name))
        !           302: 
        !           303: (defun e-setup-np-lbot nil
        !           304:    (e-move '#.np-reg '#.np-sym)
        !           305:    (e-move '#.lbot-reg '#.lbot-sym))
        !           306: 
        !           307: ;---------------MC68000 only routines
        !           308: #+for-68k
        !           309: (progn 'compile
        !           310: 
        !           311: ;--- d-regtype :: find out what type of register the operand goes
        !           312: ;                in.
        !           313: ; eiadr - an EIADR
        !           314: ;
        !           315: (defun d-regtype (eiadr)
        !           316:    (if (symbolp eiadr)
        !           317:        then (if (memq eiadr '(d0 d1 d2 d3 d4 d5 d6 d7 reg)) then 'd
        !           318:             elseif (memq eiadr '(a0 a1 a2 a3 a4 a5 a6 a7 sp areg)) then 'a)
        !           319:     elseif (or (eq '\# (car eiadr))
        !           320:               (eq '$ (car eiadr))
        !           321:               (and (eq '* (car eiadr))
        !           322:                    (eq '\# (cadr eiadr))))
        !           323:        then 'd
        !           324:        else 'a))
        !           325: 
        !           326: ;--- d-regused :: declare that a reg is used in a function
        !           327: ;      regname - name of the register that is going to be used
        !           328: ;                (ie, 'd0 'a2...)
        !           329: ;
        !           330: (defun d-regused (regname)
        !           331:    (let ((regnum (diff (cadr (exploden regname)) 48))
        !           332:         (regtype (car (explode regname))))
        !           333:        (if (memq regname '(a0 a1 d0 d1))
        !           334:           thenret
        !           335:        elseif (equal 'd regtype)
        !           336:           then (rplacx regnum g-regmaskvec t) regname
        !           337:           else (rplacx (plus regnum 8) g-regmaskvec t) regname)))
        !           338: 
        !           339: ;--- d-makemask :: make register mask for moveml instr
        !           340: ;
        !           341: (defun d-makemask ()
        !           342:    (do ((ii 0 (1+ ii))
        !           343:        (mask 0))
        !           344:        ((greaterp ii 15) mask)
        !           345:        (if (cxr ii g-regmaskvec)
        !           346:           then (setq mask (plus mask (expt 2 ii))))))
        !           347: 
        !           348: ;--- init-regmaskvec :: initalize hunk structure to all default
        !           349: ;                      save mask.
        !           350: ;
        !           351: ; nil means don't save it, and t means save the register upon function entry.
        !           352: ; order in vector: d0 .. d7, a0 .. a7.
        !           353: ; d3 : lbot (if $global-reg$ is t then save)
        !           354: ; d7 : _nilatom
        !           355: ; a2 : _np
        !           356: ; a3 : literal table ptr
        !           357: ; a4 : old _lbot (if $global-reg$ is t don't save)
        !           358: ; a5 : intermediate address calc
        !           359: ;
        !           360: (defun init-regmaskvec ()
        !           361:    (setq g-regmaskvec
        !           362:         (makhunk
        !           363:             (if $global-reg$
        !           364:                 then (quote (nil nil nil t   nil nil nil t
        !           365:                              nil nil t   t   t   t   nil nil))
        !           366:                 else (quote (nil nil nil nil nil nil nil t
        !           367:                              nil nil t   t   t   t   nil nil))))))
        !           368: 
        !           369: ;--- Cstackspace :: calc local space on C stack
        !           370: ; space = 4 * (no. of register variables saved on stack)
        !           371: ;
        !           372: (defun Cstackspace ()
        !           373:    (do ((ii 0 (1+ ii))
        !           374:        (retval 0))
        !           375:        ((greaterp ii 15) (* 4 retval))
        !           376:        (if (cxr ii g-regmaskvec) then (setq retval (1+ retval)))))
        !           377: 
        !           378: ;--- d-alloc-register :: allocate a register
        !           379: ;  type - type of register (a or d)
        !           380: ;  name - the name of the register to allocate or nil if we should
        !           381: ;        allocate the least recently used.
        !           382: ;
        !           383: (defun d-alloc-register (type name)
        !           384:    (if name 
        !           385:        then (let ((av (assoc name g-reguse)))
        !           386:                (d-regused name)
        !           387:                (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
        !           388:                name)
        !           389:        else ; find smallest used count
        !           390:            (let ((reguse))
        !           391:                (do ((cur g-reguse (cdr cur)))
        !           392:                    ((null cur))
        !           393:                    (if (eq type (car (explode (caar cur))))
        !           394:                        then (setq reguse (cons (car cur) reguse))))
        !           395:                (do ((small (car reguse))
        !           396:                     (smc (cadar reguse))
        !           397:                     (lis (cdr reguse) (cdr lis)))
        !           398:                    ((null lis)
        !           399:                     (rplaca (cdr small) (1+ smc))
        !           400:                     (d-regused (car small))
        !           401:                     (car small))
        !           402:                    (if (< (cadar lis) smc)
        !           403:                        then (setq small (car lis)
        !           404:                                   smc   (cadr small)))))))
        !           405: 
        !           406: ); end 68000 only routines

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