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