Return to decl.l CVS log

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

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

1.1     ! root        1: (include-if (null (get 'chead 'version)) "../chead.l")
        !             2: (Liszt-file decl
        !             3:    "$Header: decl.l,v 1.9 87/12/15 17:00:21 sklower Exp $")
        !             4: 
        !             5: ;;; ----       d e c l         declaration handling
        !             6: ;;;
        !             7: ;;;                            -[Sat Aug  6 23:58:35 1983 by layer]-
        !             8: 
        !             9: 
        !            10: (setq original-readtable readtable)
        !            11: (setq raw-readtable (makereadtable t))
        !            12: 
        !            13: ;--- compile-fcn  :: declare a open coded function
        !            14: ; name - name of the function
        !            15: ; fcnname - function to be funcall'ed to handle the open coding
        !            16: ; indicator -  describes what the fcnname will do, one of
        !            17: ;              fl-expr : will compile the expression and leave the
        !            18: ;                      result in r0.  Will ignore g-cc and g-loc
        !            19: ;              fl-exprcc: will compile the expression and leave the
        !            20: ;                      result in g-loc.  Will handle g-cc
        !            21: ;              fl-exprm: will just return another form to be d-exp'ed
        !            22: ; args - (optional) description of the arguments to this function.
        !            23: ;      form: (min-args . max-args) .  If max-args is nil, then there is
        !            24: ;              no max.  This is usually done in /usr/lib/lisp/fcninfo.l.
        !            25: ;
        !            26: (defmacro compile-fcn (name fcnname indicator &optional (args nil args-p))
        !            27:    `(progn (putprop ',name ',fcnname ',indicator)
        !            28:           ;; don't do this here, done in fcn-info
        !            29:           ,@(cond (args-p `((putprop ',name (list ',args) 'fcn-info))))))
        !            30: 
        !            31:           
        !            32: ;--- special handlers
        !            33: (compile-fcn and       cc-and          fl-exprcc)
        !            34: (compile-fcn arg       cc-arg          fl-exprcc)
        !            35: (compile-fcn assq      cm-assq         fl-exprm)
        !            36: (compile-fcn atom      cc-atom         fl-exprcc)
        !            37: (compile-fcn bigp      cc-bigp         fl-exprcc)
        !            38: (compile-fcn bcdcall   c-bcdcall       fl-expr)
        !            39: (compile-fcn Internal-bcdcall c-Internal-bcdcall fl-expr)
        !            40: (compile-fcn bcdp      cc-bcdp         fl-exprcc)
        !            41: #+(or for-vax for-tahoe)
        !            42: (compile-fcn boole     c-boole         fl-expr)
        !            43: (compile-fcn *catch    c-*catch        fl-expr)
        !            44: (compile-fcn comment   cc-ignore       fl-exprcc)
        !            45: (compile-fcn cond      c-cond          fl-expr)
        !            46: (compile-fcn cons      c-cons          fl-expr)
        !            47: (compile-fcn cxr       cc-cxr          fl-exprcc)
        !            48: (compile-fcn declare   c-declare       fl-expr)
        !            49: (compile-fcn do                c-do            fl-expr)
        !            50: (compile-fcn liszt-internal-do         c-do    fl-expr)
        !            51: (compile-fcn dtpr      cc-dtpr         fl-exprcc)
        !            52: (compile-fcn eq                cc-eq           fl-exprcc)
        !            53: (compile-fcn equal     cc-equal        fl-exprcc)
        !            54: (compile-fcn errset    c-errset        fl-expr)
        !            55: (compile-fcn fixp      cc-fixp         fl-exprcc)
        !            56: (compile-fcn floatp    cc-floatp       fl-exprcc)
        !            57: (compile-fcn funcall   c-funcall       fl-expr)
        !            58: (compile-fcn function  cc-function     fl-exprcc)
        !            59: (compile-fcn get       c-get           fl-expr)
        !            60: (compile-fcn getaccess  cm-getaccess    fl-exprm)
        !            61: (compile-fcn getaux    cm-getaux       fl-exprm)
        !            62: (compile-fcn getd      cm-getd         fl-exprm)
        !            63: (compile-fcn getdata   cm-getdata      fl-exprm)
        !            64: (compile-fcn getdisc   cm-getdisc      fl-exprm)
        !            65: (compile-fcn go                c-go            fl-expr)
        !            66: (compile-fcn list      c-list          fl-expr)
        !            67: (compile-fcn map       cm-map          fl-exprm)
        !            68: (compile-fcn mapc      cm-mapc         fl-exprm)
        !            69: (compile-fcn mapcan    cm-mapcan       fl-exprm)
        !            70: (compile-fcn mapcar    cm-mapcar       fl-exprm)
        !            71: (compile-fcn mapcon    cm-mapcon       fl-exprm)
        !            72: (compile-fcn maplist   cm-maplist      fl-exprm)
        !            73: (compile-fcn memq      cc-memq         fl-exprcc)
        !            74: (compile-fcn ncons     cm-ncons        fl-exprm)
        !            75: (compile-fcn not       cc-not          fl-exprcc)
        !            76: (compile-fcn null      cc-not          fl-exprcc)
        !            77: (compile-fcn numberp   cc-numberp      fl-exprcc)
        !            78: (compile-fcn or                cc-or           fl-exprcc)
        !            79: (compile-fcn prog      c-prog          fl-expr)
        !            80: (compile-fcn progn     cm-progn        fl-exprm)
        !            81: (compile-fcn prog1     cm-prog1        fl-exprm)
        !            82: (compile-fcn prog2     cm-prog2        fl-exprm)
        !            83: (compile-fcn progv     c-progv         fl-expr)
        !            84: (compile-fcn quote     cc-quote        fl-exprcc)
        !            85: (compile-fcn return    c-return        fl-expr)
        !            86: (compile-fcn rplaca    c-rplaca        fl-expr)
        !            87: (compile-fcn rplacd    c-rplacd        fl-expr)
        !            88: (compile-fcn rplacx    c-rplacx        fl-expr)
        !            89: (compile-fcn *rplacx   c-rplacx        fl-expr)
        !            90: (compile-fcn setarg    c-setarg        fl-expr)
        !            91: (compile-fcn setq      cc-setq         fl-exprcc)
        !            92: (compile-fcn stringp   cc-stringp      fl-exprcc)
        !            93: (compile-fcn symbolp   cc-symbolp      fl-exprcc)
        !            94: (compile-fcn symeval   cm-symeval      fl-exprm)
        !            95: (compile-fcn *throw    c-*throw        fl-expr)
        !            96: (compile-fcn typep     cc-typep        fl-exprcc)
        !            97: (compile-fcn vectorp           cc-vectorp      fl-exprcc)
        !            98: (compile-fcn vectorip          cc-vectorip     fl-exprcc)
        !            99: (compile-fcn vset      cc-vset         fl-exprcc)
        !           100: (compile-fcn vseti-byte cc-vseti-byte  fl-exprcc)
        !           101: (compile-fcn vseti-word cc-vseti-word  fl-exprcc)
        !           102: (compile-fcn vseti-long cc-vseti-long  fl-exprcc)
        !           103: (compile-fcn vref      cc-vref         fl-exprcc)
        !           104: (compile-fcn vrefi-byte cc-vrefi-byte  fl-exprcc)
        !           105: (compile-fcn vrefi-word cc-vrefi-word  fl-exprcc)
        !           106: (compile-fcn vrefi-long cc-vrefi-long  fl-exprcc)
        !           107: (compile-fcn vsize     c-vsize         fl-expr)
        !           108: (compile-fcn vsize-byte        c-vsize-byte    fl-expr)
        !           109: (compile-fcn vsize-word        c-vsize-word    fl-expr)
        !           110: 
        !           111: (compile-fcn zerop     cm-zerop        fl-exprm)
        !           112: ; functions which expect fixnum operands 
        !           113: 
        !           114: 
        !           115: (compile-fcn + c-fixnumop  fl-expr)
        !           116: #+(or for-vax for-tahoe) (putprop '+ 'addl3 'fixop)
        !           117: #+for-68k (putprop '+ 'addl 'fixop)
        !           118: 
        !           119: (compile-fcn - c-fixnumop fl-expr)
        !           120: #+(or for-vax for-tahoe) (putprop '- 'subl3 'fixop)
        !           121: #+for-68k (putprop '- 'subl 'fixop)
        !           122: 
        !           123: #+(or for-vax for-tahoe)
        !           124: (progn 'compile
        !           125:    (compile-fcn * c-fixnumop fl-expr)
        !           126:    (putprop '* 'mull3 'fixop)
        !           127: 
        !           128:    (compile-fcn / c-fixnumop fl-expr)
        !           129:    (putprop '/ 'divl3 'fixop))
        !           130: 
        !           131: ;-- boole's derivatives
        !           132: #+for-vax
        !           133: (progn 'compile
        !           134:    (compile-fcn fixnum-BitOr c-fixnumop fl-expr)
        !           135:    (putprop 'fixnum-BitOr 'bisl3 'fixop)
        !           136: 
        !           137:    (compile-fcn fixnum-BitAndNot c-fixnumop fl-expr)
        !           138:    (putprop 'fixnum-BitAndNot 'bicl3 'fixop)
        !           139: 
        !           140:    (compile-fcn fixnum-BitXor c-fixnumop fl-expr)
        !           141:    (putprop 'fixnum-BitXor 'xorl3 'fixop))
        !           142: 
        !           143: #+for-tahoe
        !           144: (progn 'compile
        !           145:    (compile-fcn fixnum-BitOr c-fixnumop fl-expr)
        !           146:    (putprop 'fixnum-BitOr 'orl3 'fixop)
        !           147: 
        !           148:    (compile-fcn fixnum-BitAnd c-fixnumop fl-expr)
        !           149:    (putprop 'fixnum-BitAnd 'andl3 'fixop)
        !           150: 
        !           151:    (compile-fcn fixnum-BitXor c-fixnumop fl-expr)
        !           152:    (putprop 'fixnum-BitXor 'xorl3 'fixop))
        !           153: 
        !           154: (compile-fcn 1+        cc-oneplus  fl-exprcc)
        !           155: (compile-fcn 1-                cc-oneminus fl-exprcc)
        !           156: 
        !           157: #+(or for-vax for-tahoe)
        !           158: (compile-fcn \\        c-\\    fl-expr)   ; done in the old way, should be modified
        !           159: 
        !           160: ; these have typically fixnum operands, but not always 
        !           161: 
        !           162: 
        !           163: ; these without the & can be both fixnum or both flonum
        !           164: ;
        !           165: (compile-fcn   <       cm-<    fl-exprm)
        !           166: (compile-fcn   <&      cc-<&   fl-exprcc)
        !           167: 
        !           168: (compile-fcn   >       cm->    fl-exprm)
        !           169: (compile-fcn   >&      cc->&   fl-exprcc)
        !           170: 
        !           171: (compile-fcn   =       cm-=            fl-exprm)
        !           172: (compile-fcn   =&      cm-=&           fl-exprm)
        !           173: 
        !           174: ; functions which can only be compiled
        !           175: (compile-fcn assembler-code c-assembler-code fl-expr)
        !           176: (compile-fcn fixnum-cxr cm-fixnum-cxr fl-exprm)
        !           177: (compile-fcn internal-fixnum-box c-internal-fixnum-box fl-expr)
        !           178: (compile-fcn offset-cxr cc-offset-cxr fl-exprcc)
        !           179: (compile-fcn internal-bind-vars c-internal-bind-vars fl-expr)
        !           180: (compile-fcn internal-unbind-vars c-internal-unbind-vars fl-expr)
        !           181: 
        !           182: ; functions which can be converted to fixnum functions if
        !           183: ; proper declarations are done
        !           184: (mapc
        !           185:    '(lambda (arg) (putprop (car arg) (cdr arg) 'if-fixnum-args))
        !           186:    '((lessp . <&) (greaterp . >&) (= . =&) (equal . =&)))
        !           187:      
        !           188: 
        !           189: ;--- doevalwhen, process evalwhen directive. This is inadequate.
        !           190: ;
        !           191: (def doevalwhen 
        !           192:       (lambda (v-f)
        !           193:              (prog (docom dolod)
        !           194:                    (setq docom (memq 'compile (cadr v-f))
        !           195:                          
        !           196:                          dolod (memq 'load (cadr v-f)))
        !           197:                    (mapc '(lambda (frm) (cond (docom (eval frm)))
        !           198:                                         (cond (dolod 
        !           199:                                                ((lambda (internal-macros) 
        !           200:                                                         (liszt-form frm))
        !           201:                                                 t))))
        !           202:                          (cddr v-f)))))
        !           203: 
        !           204: 
        !           205: ;---- declare - the compiler version of the declare function
        !           206: ;      process the declare forms given. We evaluate each arg
        !           207: ;
        !           208: (defun liszt-declare fexpr (forms)
        !           209:    (cond ((status feature complr)
        !           210:          (do ((i forms (cdr i)))
        !           211:              ((null i))
        !           212:              (cond ((and (atom (caar i))
        !           213:                          (getd (caar i)))
        !           214:                     (eval (car i))) ; if this is a function
        !           215:                    (t (comp-warn "Unknown declare attribute: " (car i))))))))
        !           216: 
        !           217: ;---> handlers for declare forms
        !           218: ; declaration information for declarations which occur outside of
        !           219: ; functions is stored on the property list for rapid access.
        !           220: ; The indicator to look under is the value of one of the symbols:
        !           221: ;      g-functype, g-vartype, g-bindtype, or g-calltype
        !           222: ;  The value of the property is the declared function, declaration, binding
        !           223: ;      or call type for that variable.
        !           224: ; For local declarations, the information is kept on the g-decls stack.
        !           225: ; It is an assq list, the car of which is the name of the variable or
        !           226: ; function name, the cdr of which is the particular type.  To tell
        !           227: ; whether the particular type is a function type declaration, check the
        !           228: ; property list of the particular type for a 'functype' indicator.
        !           229: ; Likewise, to see if a particular type is a variable declaration, look
        !           230: ; for a 'vartype' indicator on the particular type's property list.
        !           231: ;
        !           232: (defmacro declare-handler (args name type toplevind)
        !           233:    `(mapc '(lambda (var)
        !           234:              (cond ((symbolp var)
        !           235:                     (cond (g-compfcn   ; if compiling a function
        !           236:                              (Push g-decls (cons var ',name)))
        !           237:                           (t          ; if at top level
        !           238:                              (putprop var ',name ,toplevind))))))
        !           239:          ,args))
        !           240: 
        !           241:    
        !           242: (defun *fexpr fexpr (args)
        !           243:    (declare-handler args nlambda functype g-functype))
        !           244: 
        !           245: (defun nlambda fexpr (args)
        !           246:    (declare-handler args nlambda functype g-functype))
        !           247: 
        !           248: (defun *expr fexpr (args)
        !           249:    (declare-handler args lambda functype g-functype))
        !           250: 
        !           251: (defun lambda fexpr (args)
        !           252:    (declare-handler args lambda functype g-functype))
        !           253: 
        !           254: (defun *lexpr fexpr (args)
        !           255:    (declare-handler args lexpr functype g-functype))
        !           256: 
        !           257: (defun special fexpr (args)
        !           258:    (declare-handler args special bindtype g-bindtype))
        !           259: 
        !           260: (defun unspecial fexpr (args)
        !           261:    (declare-handler args unspecial bindtype g-bindtype))
        !           262: 
        !           263: (defun fixnum fexpr (args)
        !           264:    (declare-handler args fixnum vartype g-vartype))
        !           265: 
        !           266: (defun flonum fexpr (args)
        !           267:    (declare-handler args flonum vartype g-vartype))
        !           268: 
        !           269: (defun notype fexpr (args)
        !           270:    (declare-handler args notype vartype g-vartype))
        !           271: 
        !           272: 
        !           273: 
        !           274: ;--- special case, this is only allowed at top level.  It will
        !           275: ; be removed when vectors are fully supported
        !           276: (def macarray 
        !           277:   (nlambda (v-l)
        !           278:           (mapc '(lambda (x)
        !           279:                          (if (dtpr x)
        !           280:                              then (putprop (car x) (cdr x) g-arrayspecs)
        !           281:                                   (putprop (car x) 'array  g-functype)
        !           282:                              else (comp-err "Bad macerror form" x)))
        !           283:                 v-l)))
        !           284: 
        !           285: 
        !           286: (def macros 
        !           287:   (nlambda (args) (setq macros (car args))))
        !           288: 
        !           289: (def specials
        !           290:   (nlambda (args) (setq special (car args))))
        !           291: 
        !           292: ;--- *args
        !           293: ; form is (declare (*args minargs maxargs))
        !           294: ; this must occur within a function definition or it is an error
        !           295: ;
        !           296: (def *args
        !           297:    (nlambda (args)
        !           298:            (if (not g-compfcn)
        !           299:               then (comp-err
        !           300:                       " *args declaration not given within a function definition "
        !           301:                       args))
        !           302:            (let (min max)
        !           303:               (if (not (= (length args) 2))
        !           304:                  then (comp-err " *args declaration must have two args: "
        !           305:                                 args))
        !           306:               (setq min (car args) max (cadr args))
        !           307:               (if (not (and (or (null min) (fixp min))
        !           308:                             (or (null max) (fixp max))))
        !           309:                  then (comp-err " *args declaration has illegal values: "
        !           310:                                 args))
        !           311:               (setq g-arginfo (cons min max))
        !           312:               (putprop g-fname (list g-arginfo) 'fcn-info))))
        !           313: 
        !           314: ;--- *arginfo
        !           315: ; designed to be used at top level, but can be used within  function
        !           316: ; form: (declare (*arginfo (append 2 nil) (showstack 0 1)))
        !           317: ;
        !           318: (def *arginfo
        !           319:    (nlambda (args)
        !           320:       (do ((xx args (cdr xx))
        !           321:           (name)
        !           322:           (min)
        !           323:           (max))
        !           324:          ((null xx))
        !           325:          (if (and (dtpr (car xx))
        !           326:                   (eq (length (car xx)) 3))
        !           327:             then (setq name (caar xx)
        !           328:                        min  (cadar xx)
        !           329:                        max  (caddar xx))
        !           330:                  (if (not (and (symbolp name)
        !           331:                                (or (null min) (fixp min))
        !           332:                                (or (null max) (fixp max))))
        !           333:                     then (comp-err " *arginfo, illegal declaration "
        !           334:                                    (car xx))
        !           335:                     else (putprop name (list (cons min max)) 'fcn-info))))))
        !           336:                                                    
        !           337:    
        !           338: ;--- another top level only.
        !           339: ;
        !           340: (def localf
        !           341:   (nlambda (args)
        !           342:      (mapc '(lambda (ar)
        !           343:               (if (null (get ar g-localf))
        !           344:                  then (putprop ar
        !           345:                                (cons (d-genlab) -1)
        !           346:                                g-localf))
        !           347:               (if (get ar g-stdref)
        !           348:                  then (comp-err
        !           349:                         "function " ar " is being declared local" N
        !           350:                       " yet it has already been called in a non local way")))
        !           351:           args)))
        !           352: 
        !           353: ; g-decls is a stack of forms like
        !           354: ;  ((foo . special) (bar . fixnum) (pp . nlambda))
        !           355: ; there are 4 types of cdr's:
        !           356: ;      function types (lambda, nlambda, lexpr)
        !           357: ;      variable types (fixnum, flonum, notype)
        !           358: ;      call types     (localf, <unspecified>)
        !           359: ;      bind types     (special, unspecial)
        !           360: ;
        !           361: (mapc '(lambda (x) (putprop x t 'functype)) '(lambda nlambda lexpr))
        !           362: (mapc '(lambda (x) (putprop x t 'vartype))  '(fixnum flonum notype))
        !           363: (mapc '(lambda (x) (putprop x t 'calltype)) '(localf))
        !           364: (mapc '(lambda (x) (putprop x t 'bindtype)) '(special unspecial))
        !           365: 
        !           366: ;---> end declare form handlers
        !           367: 
        !           368: 
        !           369: 
        !           370: 
        !           371: 
        !           372: 
        !           373: ;--- d-makespec :: declare a variable to be special
        !           374: ;
        !           375: (defun d-makespec (vrb)
        !           376:   (putprop vrb 'special g-bindtype))

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