From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- type/pattern-binding.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 type/pattern-binding.scm (limited to 'type/pattern-binding.scm') 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)))))) + + + -- cgit v1.2.3