home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / declare.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  6.5 KB  |  183 lines
  1. (herald (front_end declare)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Declarations
  5.  
  6. ;;; (ANNOTATE <annotations> . <forms>)
  7. ;;; (DECLARE <key> . <data>)
  8. ;;; (DECLARE <key> . <data>) => (ANNOTATE ((<key> . <data)) (VALUES))
  9.  
  10. ;;; (declare ignore x y z)
  11. ;;; (declare ignorable x y z)
  12. ;;; (declare constant x)
  13. ;;; (declare integrate x)
  14. ;;; (declare local x)
  15. ;;; (declare simplifier x (lambda (node) ...))
  16. ;;; (declare type-safe-closed-form x y z)
  17. ;;;
  18. ;;; (annotate (integrate-here) x)
  19. ;;;
  20.  
  21. (define declaration-handler-table
  22.   (make-table 'declaration-handler-table))
  23.  
  24. ;;; Call the handler for a declaration.
  25.  
  26. (define (process-global-declaration form shape)
  27.   (destructure (((#f key . stuff) form))
  28.     (cond ((table-entry declaration-handler-table key)
  29.            => (lambda (handler)
  30.                 (handler stuff shape)))
  31.           (else
  32.            (orbit-warning '"ignoring unknown declaration type ~S~%"
  33.                           `(declare ,key . ,stuff))))))
  34.     
  35. ;;; Issue various warnings about lexical variable use and nonuse.
  36.  
  37. (define (process-lexical-declarations var)
  38.   (let ((flags (variable-flags var)))
  39.     (let ((used? (not (null? (variable-refs var))))
  40.           (ignore? (memq? 'ignore flags))
  41.           (ignorable? (memq? 'ignorable flags)))
  42.       (cond ((memq? 'duplicate flags)
  43.              (variable-message 'error
  44.                                var
  45.                                '"duplicate identifier ~S"
  46.                                '"all but one use will be ignored"))
  47.             ((not (or used? ignore? ignorable?))
  48.              (variable-message 'warning
  49.                                var
  50.                                '"unreferenced variable ~S"
  51.                                nil))
  52.             ((and used? ignore?)
  53.              (variable-message 'error
  54.                                var
  55.                                '"ignored variable ~S is referenced"
  56.                                '"the declaration will be ignored"))))
  57.     (cond ((memq? 'local flags)
  58.            (variable-message 'warning
  59.                              var
  60.                             '"lexical variable ~S is declared to be LOCAL"
  61.                             '"the declaration will be ignored")))
  62.     (if flags
  63.         (modify (variable-flags var)
  64.                 (lambda (l)
  65.                   (filter! (lambda (f)
  66.                              (not (memq? f '(ignore ignorable duplicate local))))
  67.                            l))))))
  68.  
  69. (define (variable-message type var message action)
  70.   (user-message type
  71.                 message
  72.                 action
  73.                 (variable-name var)))
  74.  
  75. ;;; A warning message for missing variables.
  76.  
  77. (define (missing-declaration-variable-warning name key)
  78.   (user-message-without-location
  79.    'warning
  80.    '"~S is in a ~S declaration and it has no top-level definition"
  81.    '"the declaration will be ignored"
  82.    name 
  83.    key))
  84.  
  85.  
  86. ;;;                   the actual declarations
  87. ;;;=============================================================================
  88.  
  89. ;;; (DEFINE-DECLARATION PATTERN SHAPE-VAR . BODY)
  90. ;;;
  91. ;;; Pattern is a lambda list, the car of which is the declaration keyword being 
  92. ;;; defined.  SHAPE-VAR will be bound to the shape.  BODY is the code that will
  93. ;;; be executed for each instance of the declaration.
  94.  
  95. (define-local-syntax (define-declaration pattern var . body)
  96.   (let ((name (car pattern))
  97.         (exp (generate-symbol 'exp)))
  98.     `(set (table-entry declaration-handler-table ',name)
  99.           (lambda (,exp . ,var)
  100.             (ignorable . ,var)
  101.             (destructure ((,(cdr pattern) ,exp))
  102.               ,@body)))))
  103.  
  104. ;;; (IGNORE . names)
  105. ;;; (IGNORABLE . names)
  106. ;;; (LOCAL . names)
  107. ;;; (CONSTANT . names)
  108. ;;; (TYPE-SAFE-CLOSED-FORM . names)
  109. ;;;
  110. ;;;  These just check that the names have the correct type of binding and mark
  111. ;;; the bound variable with the flag corresponding to the declaration.
  112.  
  113. (define-declaration (ignore . names) (shape)
  114.   (walk (lambda (name)
  115.           (let ((var (obtain-variable shape name)))
  116.             (if (variable? var)
  117.                 (push (variable-flags var) 'ignore))))
  118.         names))
  119.  
  120. (define-declaration (ignorable . names) (shape)
  121.   (walk (lambda (name)
  122.           (let ((var (obtain-variable shape name)))
  123.             (if (variable? var)
  124.                 (push (variable-flags var) 'ignorable))))
  125.         names))
  126.  
  127. (define-declaration (local . names) (shape)
  128.   (walk (lambda (name)
  129.           (cond ((new-env-definition shape name)
  130.                  => (lambda (def)
  131.                       (push (definition-data def) 'local)))
  132.                 (else
  133.                  (missing-declaration-variable-warning name 'local))))
  134.         names))
  135.  
  136. (define-declaration (constant . names) (shape)
  137.   (walk (lambda (name)
  138.           (cond ((new-env-definition shape name)
  139.                  => (lambda (def)
  140.                       (case (definition-variant def)
  141.                         ((define) (set (definition-variant def) 'constant))
  142.                         ((lset set)
  143.                   (orbit-warning '"~S variable ~S is declared to be constant"
  144.                                         (definition-variant def)
  145.                                         name))
  146.                         ((multiple)
  147.            (orbit-warning '"The CONSTANT declaration for ~S will be ignored"
  148.                           name))     
  149.                         (else
  150.                          (bug '"funny variant ~S" (definition-variant def))))))
  151.                 (else
  152.                  (missing-declaration-variable-warning name 'constant))))
  153.         names))
  154.  
  155. (define-declaration (type-safe-closed-form . names) (shape)
  156.   (walk (lambda (name)
  157.           (cond ((new-env-definition shape name)
  158.                  => (lambda (def)
  159.                       (push (definition-data def) 'type-safe-closed-form)))
  160.                 (else
  161.                  (missing-declaration-variable-warning
  162.                    name 'type-safe-closed-form))))
  163.         names))
  164.  
  165. ;;; (SIMPLIFIER name exp)
  166. ;;; EXP is evaluated in ORBIT-ENV and should be a procedure of one argument.
  167. ;;; It will be called on any call to the variable NAME.
  168.  
  169. (define-declaration (simplifier name exp) (shape)
  170.   (cond ((new-env-definition shape name)
  171.          => (lambda (def)
  172.               (let* ((clauses `(((primop.simplify self node) (,exp node))
  173.                                 ((primop.integrate? self node) nil)))
  174.                      (primop (eval (primop-code name '() clauses) orbit-env)))
  175.                 (set (primop.source primop) clauses)
  176.                 (add-new-primop shape primop)
  177.                 (set (definition-value def)
  178.                      (node->vector (create-primop-node primop))))))
  179.         (else
  180.          (missing-declaration-variable-warning name 'simplifier))))
  181.  
  182.  
  183.