Return to datab.l CVS log

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

Annotation of 43BSD/ucb/lisp/liszt/datab.l, revision 1.1

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file datab
        !             3:    "$Header: datab.l,v 1.5 83/08/28 17:14:27 layer 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 #+for-vax
        !           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: 

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