home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / front_end / analyze.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  12.4 KB  |  335 lines
  1. (herald (front_end analyze)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Checking for user errors and gathering information...
  28.  
  29. ;;; Needs to deal with object nodes
  30.  
  31. (lset *definitions* '())
  32. (lset *uses* '())
  33.  
  34. ;;; Return lists of variable definitions and uses.
  35. ;;;   *DEFINITIONS* is a list of the variables defined in the given node tree.
  36. ;;;   *USES* is a list of uses in the following form:
  37. ;;;     (<variable> <location> <use>)
  38. ;;;   <location> is either 'TOP or the variable whose value contains the use.
  39. ;;;   <use> is one of 'CALL-ARG 'OPERATION, '(CALL . <number of arguments>),
  40. ;;;     or 'WEIRD.
  41.  
  42. (define (def-and-use-analyze node)
  43.   (set *definitions* '())
  44.   (set *uses* '())
  45.   (check-call-node (lambda-body node))
  46.   (return *definitions*
  47.           (map! (lambda (u)
  48.                   (cons *current-module-exp* u))
  49.                 *uses*)))
  50.  
  51. ;;; Check a value node - look at the body of lambdas and the definitions of
  52. ;;; variables.     
  53.  
  54. (define (check-value-node node)
  55.   (cond ((lambda-node? node)
  56.          (check-call-node (lambda-body node))
  57.          (if (fx> (length (lambda-variables node))
  58.                   (fx+ *maximum-number-of-arguments* 1))
  59.              (too-many-lambda-variables node)))
  60.         ((object-node? node)
  61.          (check-value-list (object-operations node))
  62.          (check-value-list (object-methods node))
  63.          (check-value-node (object-proc node)))
  64.         ((and (reference-node? node)
  65.               (variable-definition (reference-variable node)))
  66.          => (lambda (def)
  67.               (if (local-definition? def)
  68.                   (push *uses*
  69.                         `(,(reference-variable node) ,(node-use node))))))))
  70.  
  71. (define (check-value-list list)
  72.   (walk (lambda (node)
  73.           (if node
  74.               (check-value-node node)))
  75.         list))
  76.  
  77. (define (too-many-lambda-variables node)
  78.   (let* ((var (create-variable 'x))
  79.          (l-node (create-lambda-node 'l (list var))))
  80.     (fix-user-error (lambda-body node)
  81.            "maximum formal count exceeded: ~D formal parameters, maximum is ~D"
  82.            (length (cdr (lambda-variables node)))
  83.            *maximum-number-of-arguments*)
  84.     (relate lambda-body l-node (detach (lambda-body node)))
  85.     (replace node l-node)))
  86.  
  87. ;;; Check calls.  Checks the procedure and then dispatches on the type of
  88. ;;; the call.
  89.  
  90. (define (check-call-node call)
  91.   (cond ((fx> (length (call-args call)) (fx+ *maximum-number-of-arguments* 1))
  92.          (fix-user-error call
  93.              "maximum argument count exceeded: ~D arguments, maximum is ~D"
  94.              (length (cdr (call-args call)))
  95.              *maximum-number-of-arguments*))
  96.         ((variable-definition? call)
  97.          (check-value-node ((call-arg '1) call))
  98.          (check-value-node ((call-arg '3) call)) 
  99.          (add-definition-value call))
  100.         ((primop-ref? (call-proc call) primop/y)
  101.          (check-y ((call-arg '2) call))
  102.          (check-value-node ((call-arg '1) call)))
  103.         ((lambda-node? (call-proc call))
  104.          (set-check-flags (lambda-variables (call-proc call)) (call-args call))
  105.          (check-value-list (call-proc+args call))
  106.          (reset-check-flags (lambda-variables (call-proc call)))
  107.          (check-call-using-proc call))
  108.         (else
  109.          (check-value-list (call-proc+args call))
  110.          (check-call-using-proc call))))
  111.  
  112. ;;; Does CALL define a variable.
  113.  
  114. (define (variable-definition? call)
  115.   (let ((primop (known-primop (call-proc call))))
  116.     (and primop
  117.          (primop.definition? primop)
  118.          (neq? (primop.definition-variant primop) 'set)
  119.          (fx= '3 (length (call-args call)))
  120.          (reference-node? ((call-arg '2) call))
  121.          (variable-definition (reference-variable ((call-arg '2) call))))))
  122.  
  123. ;;; Set the definition value and type of a variable.
  124.  
  125. (define (add-definition-value call)
  126.   (destructure (((proc cont ref val) (call-proc+args call)))
  127.     (ignore proc)
  128.     (let* ((var (reference-variable ref))
  129.            (def (variable-definition var))
  130.            (variant (definition-variant def)))
  131.       (ignore cont)   
  132.       (if (and (not (memq? var *definitions*))
  133.                (neq? variant 'set))
  134.           (push *definitions* var))
  135.       (real-add-definition-value var val))))
  136.  
  137. (define (real-add-definition-value var val)
  138.   (let ((def (variable-definition var)))
  139.     (cond ((and (or (eq? (definition-variant def) 'define)
  140.                     (eq? (definition-variant def) 'constant))
  141.                 (not (definition->primop def)))
  142.            (if (eq? (definition-variant def) 'constant)
  143.                (set (definition-value def) (node->vector val)))
  144.            (set (definition-type def)
  145.                 (get-node-definition-type val))
  146.            t)
  147.           (else nil))))
  148.  
  149. ;;; Type check of a call using the type of the procedure.
  150.  
  151. (define (check-call-using-proc node)
  152.   (let ((proc (call-proc node)))
  153.     (cond ((literal-node? proc)
  154.            (fix-call-to-literal node (literal-value proc)))
  155.           ((reference-node? proc)
  156.            (check-call-to-var node (reference-variable proc)))
  157.           ((and (lambda-node? proc)      
  158.                 (not (arg-check-of-lambda proc node)))
  159.            (fix-call-to-lambda node proc)))))
  160.  
  161. ;;; Special procedure for checking calls to Y.
  162.  
  163. (define (check-y l-node)
  164.   (let ((vals (cdr (call-args (lambda-body l-node)))))
  165.     (set-check-flags (cdr (lambda-variables l-node))
  166.                      (map thunk-value vals))
  167.     (check-value-node ((call-arg '1) (lambda-body l-node)))
  168.     (check-value-list vals)
  169.     (reset-check-flags (lambda-variables l-node))))
  170.  
  171. ;;; Variables that have known values keep those values in the VARIABLE-FLAG
  172. ;;; field for the purposes of type checking.
  173.  
  174. (define (clear-check-flags node)
  175.   (if (lambda-node? (call-proc node))
  176.       (reset-check-flags (lambda-variables (call-proc node)))))
  177.  
  178. (define (set-check-flags vars args)
  179.   (walk (lambda (var val)
  180.           (if (and var val (lambda-node? val))
  181.               (set (variable-flag var) val)))
  182.         vars
  183.         args))
  184.  
  185. (define (reset-check-flags vars)
  186.   (walk (lambda (var)
  187.           (if var (set (variable-flag var) nil)))
  188.         vars))
  189.  
  190. ;;; Checking a call to a known variables
  191.  
  192. (define (check-call-to-var call var)
  193.   (cond ((variable-binder var)
  194.          (check-call-to-lexical-var call var))
  195.         ((get-variable-definition var)
  196.          => (lambda (def)
  197.               (if (not (local-definition? def))
  198.                   (check-call-to-bound-var call def))))))
  199.  
  200. (define (check-call-to-lexical-var call var)
  201.   (let ((type (variable-flag var)))
  202.     (cond ((and (node? type)
  203.                 (lambda-node? type)
  204.                 (not (arg-check-of-lambda type call)))
  205.            (fix-call-to-bound-lambda call var type)))))
  206.  
  207. (define (check-call-to-bound-var call def)
  208.   (let ((type (definition-type def)))
  209.     (cond ((eq? type 'literal)
  210.            (fix-call-to-early-bound-literal (call-proc call))
  211.            (replace-with-free-variable (call-proc call)))
  212.           ((and (pair? type)
  213.                 (eq? (car type) 'proc)
  214.                 (not (arg-check-of-type type call)))
  215.            (fix-call-to-early-bound-proc (call-proc call))))))
  216.  
  217. (define (arg-check-of-lambda proc node)
  218.   (let ((left-over (fx- (length (call-args node))
  219.                         (length (lambda-variables proc)))))
  220.     (or (fx= left-over '0)
  221.         (and (fx> left-over '0)
  222.              (lambda-rest-var proc)))))
  223.     
  224. (define (arg-check-of-type type node)
  225.   (cond ((eq? type 'object)
  226.          t)
  227.         (else
  228.          (let ((left-over (fx- (length (call-args node))
  229.                                        (caddr type))))
  230.            (or (fx= left-over '0)
  231.                (and (fx> left-over '0)
  232.                     (cadr type)))))))
  233.  
  234. ;;; Is TYPE okay if we ignore the continuation
  235.  
  236. (define (arg-check-of-return-type type node)
  237.   (cond ((eq? type 'object)
  238.          t)
  239.         (else
  240.          (let ((left-over (fx- (fx- (length (call-args node)) 1)
  241.                                (caddr type))))
  242.            (or (fx= left-over '0)
  243.                (and (fx> left-over '0)
  244.                     (cadr type)))))))
  245.  
  246. ;;; The way in which a node is used.  Returns one of (CALL . <# of arguments>),
  247. ;;; OPERATION, CALL-ARG, or WEIRD.
  248.  
  249. (define (node-use node)
  250.   (let ((role (node-role node)))
  251.     (cond ((eq? role call-proc)
  252.            `(call . ,(length (call-args (node-parent node)))))
  253.           ((object-op? role) 'operation)
  254.           ((call-arg? node) 'call-arg)
  255.           (else 'weird))))
  256.  
  257. (define (use-type use)
  258.   (definition-type (variable-definition (cadr use))))
  259.  
  260. (define (check-uses new-uses old-uses)
  261.   (iterate loop ((uses (append new-uses old-uses))
  262.                  (left '()))
  263.     (cond ((null? uses)
  264.            left)
  265.           ((use-type (car uses))
  266.            => (lambda (type)
  267.                 (check-variable-use (car uses) type)
  268.                 (loop (cdr uses) left)))
  269.           (else
  270.            (loop (cdr uses) (cons (car uses) left))))))
  271.  
  272. (define (check-variable-use use var-type)
  273.   (destructure (((loc var use-type) use))
  274.     (cond ((or (not var-type)
  275.                (eq? use-type 'call-arg)
  276.                (eq? use-type 'weird))
  277.            t)
  278.           ((eq? use-type 'operation)
  279.            t)  ; Operations are not annotated yet
  280.           ((or (not (pair? use-type))
  281.                (neq? 'call (car use-type)))
  282.            (bug '"unknown use-type ~S in CHECK-VARIABLE-USE" use-type))
  283.           ((eq? var-type 'literal)
  284.            (user-message-with-location 'warning
  285.                                        loc
  286.                                        '"call to ~S which is bound to a literal" 
  287.                                        nil
  288.                                        (variable-name var)))
  289.           ((and (pair? var-type)
  290.                 (eq? (car var-type) 'proc))
  291.            (if (not (arg-check-of-use var-type use-type))
  292.                (user-message-with-location
  293.                 'warning
  294.                 loc
  295.                 '"wrong number of arguments in a call to ~A"
  296.                 nil
  297.                 (variable-name var)))))))
  298.  
  299. (define (arg-check-of-use var-type use-type)
  300.   (let ((left-over (fx- (cdr use-type)
  301.                         (caddr var-type))))
  302.     (or (fx= left-over '0)
  303.         (and (fx> left-over '0)
  304.              (cadr var-type)))))
  305.  
  306. ;;; Quick version of the above.  Just finds defs and uses.  This is used on
  307. ;;; integrable definitions before they are simplified.
  308.  
  309. (define (quick-def-and-use-analyze node)
  310.   (let ((uses '()) (defs '()))
  311.     (iterate tree-walk ((node node))
  312.       (cond ((lambda-node? node)
  313.              (let ((call (lambda-body node)))
  314.                (if (variable-definition? call)
  315.                    (let ((var (reference-variable ((call-arg '2) call))))
  316.                      (push defs var)))
  317.                (walk tree-walk (call-proc+args call))))
  318.             ((object-node? node)
  319.              (tree-walk (object-proc node))
  320.              (walk tree-walk (object-methods node)))
  321.             ((and (reference-node? node)
  322.                   (variable-definition (reference-variable node)))
  323.              => (lambda (def)
  324.                   (let ((var (reference-variable node)))
  325.                     (if (and (local-definition? def)
  326.                              (not (memq? var uses)))
  327.                         (push uses var)))))))
  328.     (return defs uses)))
  329.  
  330.  
  331.  
  332.  
  333.  
  334.  
  335.