home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / util.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  12.2 KB  |  409 lines
  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
  409.