diff options
author | Yale AI Dept <ai@nebula.cs.yale.edu> | 1993-07-14 13:08:00 -0500 |
---|---|---|
committer | Duncan McGreggor <duncan.mcgreggor@rackspace.com> | 1993-07-14 13:08:00 -0500 |
commit | 4e987026148fe65c323afbc93cd560c07bf06b3f (patch) | |
tree | 26ae54177389edcbe453d25a00c38c2774e8b7d4 /type/pattern-binding.scm |
Import to github.
Diffstat (limited to 'type/pattern-binding.scm')
-rw-r--r-- | type/pattern-binding.scm | 38 |
1 files changed, 38 insertions, 0 deletions
diff --git a/type/pattern-binding.scm b/type/pattern-binding.scm new file mode 100644 index 0000000..769e155 --- /dev/null +++ b/type/pattern-binding.scm @@ -0,0 +1,38 @@ +;;; This implements the pattern binding rule. + +(define (apply-pattern-binding-rule? decls) + (not + (every (lambda (decl) + (or (function-binding? decl) + (simple-pattern-binding-with-signature? decl))) + decls))) + +(define (function-binding? decl) + (let ((defs (valdef-definitions decl))) + (not (null? (single-fun-def-args (car defs)))))) + +(define (simple-pattern-binding-with-signature? decl) + (let ((lhs (valdef-lhs decl)) + (defs (valdef-definitions decl))) + (and (is-type? 'var-pat lhs) + (null? (single-fun-def-args (car defs))) + (not (eq? (var-signature (var-ref-var (var-pat-var lhs))) '#f))))) + +(define (do-pattern-binding-rule decls necessary-tyvars ng-list) + (setf ng-list (append necessary-tyvars ng-list)) + (find-exported-pattern-bindings decls) + ng-list) + +(define (find-exported-pattern-bindings decls) + (dolist (decl decls) + (dolist (var-ref (collect-pattern-vars (valdef-lhs decl))) + (let ((var (var-ref-var var-ref))) + (when (def-exported? var) + (recoverable-error 'exported-pattern-binding + "Can't export pattern binding of ~A~%" var-ref)) + (when (not (eq? (var-signature var) '#f)) + (recoverable-error 'entire-group-needs-signature + "Variable ~A signature declaration ignored~%" var-ref)))))) + + + |