home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / lisp / liszt / datab.l < prev    next >
Encoding:
Text File  |  1987-12-15  |  7.1 KB  |  237 lines
  1. (include-if (null (get 'chead 'version)) "../chead.l")
  2. (Liszt-file datab
  3.    "$Header: datab.l,v 1.6 87/12/15 16:59:55 sklower Exp $")
  4.  
  5. ;;; ----    d a t a b            data base
  6. ;;;
  7. ;;;                -[Sat Aug  6 23:59:11 1983 by layer]-
  8.  
  9. ;--- d-tranloc :: locate a function in the transfer table
  10. ;
  11. ; return the offset we should use for this function call
  12. ;
  13. (defun d-tranloc (fname)
  14.    (cond ((get fname g-tranloc))
  15.      (t (Push g-tran fname)
  16.         (let ((newval (* 8 g-trancnt)))
  17.         (putprop fname newval g-tranloc)
  18.         (incr g-trancnt)
  19.         newval))))
  20.  
  21.  
  22. ;--- d-loc :: return the location of the variable or value in IADR form 
  23. ;    - form : form whose value we are to locate
  24. ;
  25. ; if we are given a xxx as form, we check yyy;
  26. ;    xxx        yyy
  27. ;     --------         ---------
  28. ;    nil         Nil is always returned
  29. ;    symbol         return the location of the symbols value, first looking
  30. ;             in the registers, then on the stack, then the bind list.
  31. ;             If g-ingorereg is t then we don't check the registers.
  32. ;             We would want to do this if we were interested in storing
  33. ;             something in the symbol's value location.
  34. ;    number         always return the location of the number on the bind
  35. ;             list (as a (lbind n))
  36. ;    other         always return the location of the other on the bind
  37. ;             list (as a (lbind n))
  38. ;
  39. (defun d-loc (form)
  40.    (if (null form) then 'Nil
  41.     elseif (numberp form) then
  42.      (if (and (fixp form) (greaterp form -1025) (lessp form 1024))
  43.          then `(fixnum ,form)        ; small fixnum
  44.          else (d-loclit form nil))
  45.     elseif (symbolp form) 
  46.        then (if (and (null g-ignorereg) (car (d-bestreg form nil))) thenret
  47.         else (if (d-specialp form) then (d-loclit form t)
  48.              else (do ((ll g-locs (cdr ll))    ; check stack
  49.                    (n g-loccnt))
  50.                   ((null ll)
  51.                    (comp-warn (or form)
  52.                           " declared special by compiler")
  53.                    (d-makespec form)
  54.                    (d-loclit form t))
  55.                   (if (atom (car ll))
  56.                       then (if (eq form (car ll))
  57.                            then (return `(stack ,n))
  58.                            else (setq n (1- n)))))))
  59.        else (d-loclit form nil)))
  60.  
  61.  
  62. ;--- d-loclit :: locate or add litteral to bind list
  63. ;    - form : form to check for and add if not present
  64. ;    - flag : if t then if we are given a symbol, return the location of
  65. ;         its value, else return the location of the symbol itself
  66. ;
  67. ; scheme: we share the locations of atom (symbols,numbers,string) but always
  68. ;     create a fresh copy of anything else.
  69. (defun d-loclit (form flag)
  70.    (prog (loc onplist symboltype)
  71.        (if (null form) 
  72.        then (return 'Nil)
  73.     elseif (symbolp form)
  74.        then (setq symboltype t)
  75.         (cond ((setq loc (get form g-bindloc))
  76.                (setq onplist t)))
  77.     elseif (atom form)
  78.        then (do ((ll g-lits (cdr ll))    ; search for atom on list
  79.              (n g-litcnt (1- n)))
  80.             ((null ll))
  81.             (if (eq form (car ll))
  82.             then (setq loc n)    ; found it
  83.                  (return))))    ; leave do
  84.        (if (null loc)
  85.        then (Push g-lits form)
  86.         (setq g-litcnt (1+ g-litcnt)
  87.               loc g-litcnt)
  88.         (cond ((and symboltype (null onplist))
  89.                (putprop form loc g-bindloc))))
  90.  
  91.        (return (if (and flag symboltype) then `(bind ,loc)
  92.            else `(lbind ,loc)))))
  93.                  
  94.  
  95.  
  96. ;--- d-locv :: find the location of a value cell, and dont return a register
  97. ;
  98. (defun d-locv (sm)
  99.   (let ((g-ignorereg t))
  100.        (d-loc sm)))
  101.  
  102.  
  103. ;--- d-simple :: see of arg can be addresses in one instruction
  104. ; we define simple and really simple as follows
  105. ;  <rsimple> ::= number
  106. ;         quoted anything
  107. ;         local symbol
  108. ;         t
  109. ;         nil
  110. ;  <simple>  ::= <rsimple>
  111. ;         (cdr <rsimple>)
  112. ;         global symbol
  113. ;
  114. (defun d-simple (arg)
  115.    (let (tmp)
  116.        (if (d-rsimple arg) thenret
  117.     elseif (atom arg) then (d-loc arg)
  118.     elseif (and (memq (car arg) '(cdr car cddr cdar))
  119.             (setq tmp (d-rsimple (cadr arg))))
  120.        then (if (eq 'Nil tmp) then tmp
  121.          elseif (atom tmp)
  122.             then #+(or for-vax for-tahoe)
  123.              (if (eq 'car (car arg))
  124.                  then `(racc 4 ,tmp)
  125.               elseif (eq 'cdr (car arg))
  126.                  then `(racc 0 ,tmp)
  127.               elseif (eq 'cddr (car arg))
  128.                  then `(racc * 0 ,tmp)
  129.               elseif (eq 'cdar (car arg))
  130.                  then `(racc * 4 ,tmp))
  131.              #+for-68k
  132.              (if (eq 'car (car arg))
  133.                  then `(racc 4 ,tmp)
  134.               elseif (eq 'cdr (car arg))
  135.                  then `(racc 0 ,tmp))
  136.          elseif (not (eq 'cdr (car arg)))
  137.             then nil
  138.          elseif (eq 'lbind (car tmp))
  139.             then `(bind ,(cadr tmp))
  140.          elseif (eq 'stack (car tmp))
  141.             then `(vstack ,(cadr tmp))
  142.          elseif (eq 'fixnum (car tmp))
  143.             then `(immed ,(cadr tmp))
  144.          elseif (atom (car tmp))
  145.             then `(0 ,(cadr tmp))
  146.             else (comp-err "bad arg to d-simple: " (or arg))))))
  147.  
  148. (defun d-rsimple (arg)
  149.    (if (atom arg) then
  150.        (if (null arg) then 'Nil
  151.     elseif (eq t arg) then 'T
  152.     elseif (or (numberp arg)
  153.            (memq arg g-locs)) 
  154.        then (d-loc arg)
  155.        else (car (d-bestreg arg nil)))
  156.     elseif (eq 'quote (car arg)) then (d-loclit (cadr arg) nil)))
  157.  
  158. ;--- d-specialp :: check if a variable is special
  159. ; a varible is special if it has been declared as such, or if
  160. ; the variable special is t
  161. (defun d-specialp (vrb)
  162.   (or special
  163.       (eq 'special (d-findfirstprop vrb 'bindtype))   ; local special decl
  164.       (eq 'special (get vrb g-bindtype))))
  165.  
  166. (defun d-fixnump (vrb)
  167.    (and (symbolp vrb)
  168.     (or (eq 'fixnum (d-findfirstprop vrb 'vartype))
  169.         (eq 'fixnum (get vrb g-vartype)))))
  170.  
  171. ;--- d-functyp :: return the type of function
  172. ;    - name : function name
  173. ;
  174. ; If name had a macro function definition, we return `macro'.  Otherwise
  175. ; we see if name as a declared type, if so we return that.  Otherwise
  176. ; we see if name is defined and we return that if so, and finally if
  177. ; we have no idea what this function is, we return lambda.
  178. ;   This is not really satisfactory, but will handle most cases.
  179. ;
  180. ; If macrochk is nil then we don't check for the macro case.  This
  181. ; is important to prevent recursive macroexpansion.
  182. ;
  183. (defun d-functyp (name macrochk)
  184.    (let (func ftyp)
  185.       (if (atom name) 
  186.      then
  187.           (setq func (getd name))
  188.           (setq ftyp (if (and macrochk (get name 'cmacro)) ;compiler macro
  189.                 then 'cmacro
  190.               elseif (bcdp func)
  191.                 then (let ((type (getdisc func)))
  192.                     (if (memq type '(lambda nlambda macro))
  193.                        then type
  194.                      elseif (stringp type)
  195.                        then 'lambda    ; foreign function
  196.                        else (comp-warn
  197.                            "function "
  198.                            name
  199.                            " has a strange discipline "
  200.                            type)
  201.                         'lambda    ; assume lambda
  202.                     ))
  203.               elseif (dtpr func)
  204.                 then (car func)
  205.               elseif (and macrochk (get name 'macro-autoload))
  206.                 then 'macro))
  207.           (if (memq ftyp '(macro cmacro)) then ftyp
  208.            elseif (d-findfirstprop name 'functype) thenret
  209.            elseif (get name g-functype) thenret  ; check if declared first
  210.            elseif ftyp thenret
  211.          else 'lambda)
  212.      else 'lambda)))        ; default is lambda
  213.  
  214. ;--- d-allfixnumargs :: check if all forms are fixnums
  215. ; make sure all forms are fixnums or symbols whose declared type are fixnums
  216. ;
  217. (defun d-allfixnumargs (forms)
  218.    (do ((xx forms (cdr xx))
  219.     (arg))
  220.        ((null xx) t)
  221.        (cond ((and (fixp (setq arg (car xx))) (not (bigp arg))))
  222.          ((d-fixnump arg))
  223.          (t (return nil)))))
  224.  
  225.           
  226. (defun d-findfirstprop (name type)
  227.    (do ((xx g-decls (cdr xx))
  228.     (rcd))
  229.        ((null xx))
  230.        (if (and (eq name (caar xx))
  231.         (get (setq rcd (cdar xx)) type))
  232.       then (return rcd))))
  233.  
  234.           
  235.  
  236.  
  237.