diff --git a/js2/semantics/Calculus.lisp b/js2/semantics/Calculus.lisp index 482865be02bc..ca82a67c47f7 100644 --- a/js2/semantics/Calculus.lisp +++ b/js2/semantics/Calculus.lisp @@ -29,7 +29,8 @@ #+mcl (dolist (indent-spec '((? . 1) (apply . 1) (funcall . 1) (production . 3) (rule . 2) (function . 2) (deftag . 1) (defrecord . 1) (deftype . 1) (tag . 1) (%text . 1) - (var . 2) (const . 2) (rwhen . 1) (while . 1) (:narrow . 1) (:select . 1))) + (var . 2) (const . 2) (rwhen . 1) (while . 1) (:narrow . 1) (:select . 1) + (let-local-var . 2))) (pushnew indent-spec ccl:*fred-special-indent-alist* :test #'equal)) @@ -299,13 +300,6 @@ (error "max of empty character-set")))) -(defun integer-set-member (elt intset) - (intset-member? intset elt)) - -(defun character-set-member (elt intset) - (intset-member? intset (char-code elt))) - - ;;; ------------------------------------------------------------------------------------------------------ ;;; CODE GENERATION @@ -502,6 +496,26 @@ (list 'lambda args (apply #'gen-apply expr args))))) +; Generate a local variable for holding the value of expr. Optimize the case where expr +; is an identifier or a number. +(defun gen-local-var (expr) + (if (or (symbolp expr) (numberp expr)) + expr + (gensym "L"))) + + +; var should have been obtained from calling gen-local-var on expr. Return +; `(let ((,var ,expr)) ,body-code), +; optimizing the cases that gen-local-var optimizes. +(defmacro let-local-var (var expr body-code) + (let ((body (gensym "BODY"))) + `(let ((,body ,body-code)) + (if (eql ,var ,expr) + ,body + (list 'let (list (list ,var ,expr)) ,body))))) + + + ;;; ------------------------------------------------------------------------------------------------------ ;;; LF TOKENS @@ -804,11 +818,13 @@ ;;; annotated-stmts is a list of generated annotated statements ;;; :special-form expression code generation function ((world type-env id . form-arg-list) -> code, type, annotated-expr) ;;; if this identifier is a special form like 'tag or 'in +;;; :condition boolean condition code generation function ((world type-env id . form-arg-list) -> code, annotated-expr, true-type-env, false-type-env) +;;; if this identifier is a condition form like 'and or 'in ;;; ;;; :primitive primitive structure if this identifier is a primitive ;;; ;;; :type-constructor expression code generation function ((world allow-forward-references . form-arg-list) -> type) if this -;;; identifier is a type constructor like '->, 'vector, 'set, 'tag, or 'union +;;; identifier is a type constructor like '->, 'vector, 'range-set, 'tag, or 'union ;;; :deftype type if this identifier is a type; nil if this identifier is a forward-referenced type ;;; ;;; value of this identifier if it is a variable of type other than -> @@ -817,6 +833,7 @@ ;;; :type type of this identifier if it is a variable ;;; :type-expr unparsed expression defining the type of this identifier if it is a variable ;;; :tag tag structure if this identifier is a tag +;;; :tag-hidden a flag that, if true, indicates that this tag's name should not be visible ;;; :tag= a two-argument function that takes two values with this tag and compares them ;;; ;;; :action list of (grammar-info . grammar-symbol) that declare this action if this identifier is an action name @@ -942,7 +959,8 @@ ; Define a new tag. Signal an error if the name is already used. Return the tag. ; Do not evaluate the field and type expressions yet; that will be done by eval-tags-types. -(defun add-tag (world name mutable fields link) +; If hidden is true, mark the tag as hidden so that its name cannot be used to access it. +(defun add-tag (world name mutable fields link hidden) (assert-true (member link '(nil :reference :external))) (let ((name (scan-name world name))) (when (symbol-tag name) @@ -956,6 +974,8 @@ (setf (get name :tag=) #'eq)) (let ((tag (make-tag name keyword mutable fields =-name link))) (setf (symbol-tag name) tag) + (when hidden + (setf (get name :tag-hidden) t)) (export-symbol name) tag)))) @@ -992,9 +1012,12 @@ ; Return the tag with the given un-world-interned name. Signal an error if one wasn't found. (defun scan-tag (world tag-name) - (let ((name (world-find-symbol world tag-name))) - (or (symbol-tag name) - (error "No tag ~A defined" tag-name)))) + (let* ((name (world-find-symbol world tag-name)) + (tag (symbol-tag name)) + (hidden (get name :tag-hidden))) + (unless tag + (error "No tag ~A defined" tag-name)) + (if hidden nil tag))) ; Scan label to produce a label that is present in the given tag. @@ -1037,7 +1060,8 @@ :-> ;nil ;(result-type arg1-type arg2-type ... argn-type) :string ;nil ;(character) :vector ;nil ;(element-type) - :set ;nil ;(element-type) + :list-set ;nil ;(element-type) + :range-set ;nil ;(element-type) :tag ;tag ;nil :denormalized-tag ;tag ;nil :union)) ;nil ;(type ... type) sorted by ascending serial numbers @@ -1093,13 +1117,23 @@ (car (type-parameters type))) -(declaim (inline make-set-type)) -(defun make-set-type (world element-type) - (make-type world :set nil (list element-type) 'intset= nil)) +(declaim (inline make-list-set-type)) +(defun make-list-set-type (world element-type) + (make-type world :list-set nil (list element-type) nil nil)) + +(declaim (inline make-range-set-type)) +(defun make-range-set-type (world element-type) + (make-type world :range-set nil (list element-type) intset=-name nil)) (declaim (inline set-element-type)) (defun set-element-type (type) - (assert-true (eq (type-kind type) :set)) + (assert-true (member (type-kind type) '(:list-set :range-set))) + (car (type-parameters type))) + + +(declaim (inline collection-element-type)) +(defun collection-element-type (type) + (assert-true (member (type-kind type) '(:vector :string :list-set :range-set))) (car (type-parameters type))) @@ -1124,12 +1158,15 @@ (make-type world :denormalized-tag tag nil 'always-true 'always-false)) -; Return three values: -; the one-based position of the type's field corresponding to the given label or nil if the label is not present; -; the type the field; -; true if the field is mutable. -(defun type-find-field (type label) - (tag-find-field (type-tag type) label)) +; Return true if the type is a tag type or a union of tag types all of which have a field with +; the given label. +(defun type-has-field (type label) + (flet ((test (type) + (and (eq (type-kind type) :tag) + (tag-find-field (type-tag type) label)))) + (case (type-kind type) + (:tag (test type)) + (:union (every #'test (type-parameters type)))))) ; Equivalent types are guaranteed to be eq to each other. @@ -1230,11 +1267,11 @@ (list 'union-finite64-to-rational code) code))) (t (type-mismatch))))) - (:vector - (unless (eq kind :vector) + ((:vector :list-set) + (unless (eq kind (type-kind supertype)) (type-mismatch)) (let* ((par (gensym "PAR")) - (element-coercion-code (widening-coercion-code world (vector-element-type supertype) (vector-element-type type) par expr))) + (element-coercion-code (widening-coercion-code world (collection-element-type supertype) (collection-element-type type) par expr))) (if (eq element-coercion-code par) code `(mapcar #'(lambda (,par) ,element-coercion-code) code)))) @@ -1301,7 +1338,8 @@ (t (make-type world :union nil types nil nil)))) -; Return the union of type1 and type2. +; Return the union U of type1 and type2. Note that a value of type1 or type2 might need to be coerced to +; be treated as a member of type U. (defun type-union (world type1 type2) (labels ((numeric-kind (kind) @@ -1323,10 +1361,15 @@ (setq types (merge-type-lists (remove-if #'numeric-type types) (list (world-rational-type world))))) (assert-true (type-list-sorted types)) (reduce-union-type world types t))) + ((and (eq kind1 :vector) (eq kind2 :vector)) + (make-vector-type world (type-union world (vector-element-type type1) (vector-element-type type2)))) + ((and (eq kind1 :list-set) (eq kind2 :list-set)) + (make-list-set-type world (type-union world (set-element-type type1) (set-element-type type2)))) (t (error "No union of types ~A and ~A" (print-type-to-string type1) (print-type-to-string type2)))))))) -; Return the most specific common supertype of the types. +; Return the most specific common supertype of the types. Note that a value of one of the given types may need to be +; coerced to be treated as a member of type U. (defun make-union-type (world &rest types) (if types (reduce #'(lambda (type1 type2) (type-union world type1 type2)) @@ -1334,6 +1377,29 @@ (world-bottom-type world))) +; Return the intersection I of type1 and type2. Note that a value of type I might need to be coerced to +; be treated as a member of type1 or type2. +; Not all intersections have been implemented yet. +(defun type-intersection (world type1 type2) + (declare (ignore world)) + (if (type= type1 type2) + type1 + (let ((kind1 (type-kind type1)) + (kind2 (type-kind type2))) + (cond + ((eq kind1 :bottom) type1) + ((eq kind2 :bottom) type2) + (t (error "No intersection of types ~A and ~A" (print-type-to-string type1) (print-type-to-string type2))))))) + + +; Return the most specific common supertype of the types. Note that a value of the intersection type may need to be +; coerced to be treated as a member of one of the given types. +(defun make-intersection-type (world &rest types) + (assert-true types) + (reduce #'(lambda (type1 type2) (type-intersection world type1 type2)) + types)) + + ; Ensure that subtype is a subtype of type. subtype must not be the bottom type. ; Return two values: ; subtype1, a type that is equivalent to subtype but may be denormalized. @@ -1495,9 +1561,12 @@ (:vector (pprint-logical-block (stream nil :prefix "(" :suffix ")") (format stream "vector ~@_") (print-type (vector-element-type type) stream))) - (:set (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (format stream "set ~@_") - (print-type (set-element-type type) stream))) + (:list-set (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (format stream "list-set ~@_") + (print-type (set-element-type type) stream))) + (:range-set (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (format stream "range-set ~@_") + (print-type (set-element-type type) stream))) (:tag (let ((tag (type-tag type))) (pprint-logical-block (stream nil :prefix "(" :suffix ")") (format stream "tag ~@_~A" (tag-name tag))))) @@ -1611,9 +1680,13 @@ (make-vector-type world (scan-type world element-type allow-forward-references))) -; (set ) -(defun scan-set (world allow-forward-references element-type) - (make-set-type world (scan-type world element-type allow-forward-references))) +; (list-set ) +(defun scan-list-set (world allow-forward-references element-type) + (make-list-set-type world (scan-type world element-type allow-forward-references))) + +; (range-set ) +(defun scan-range-set (world allow-forward-references element-type) + (make-range-set-type world (scan-type world element-type allow-forward-references))) ; (tag ... ) @@ -1757,6 +1830,14 @@ ;;; COMPARISONS +; Return (:test ), simplifying to nil if the equality function is eql. +(defun element-test (world type) + (let ((test (get-type-=-name world type))) + (if (eq test 'eql) + nil + `(:test #',test)))) + + ; Return non-nil if the values are equal. value1 and value2 must both belong to a union type. (defun union= (value1 value2) (or (eql value1 value2) @@ -1781,6 +1862,18 @@ =-name))))) +; Create an equality comparison function for elements of the given :list-set type. +; Return the name of the function and also set it in the type. +(defun compute-list-set-type-=-name (world type) + (let* ((element-type (set-element-type type)) + (=-name (gentemp (format nil "~A_LISTSET_=" (type-name element-type)) (world-package world)))) + (setf (type-=-name type) =-name) ;Must do this now to prevent runaway recursion. + (quiet-compile =-name `(lambda (a b) + (and (= (length a) (length b)) + (subsetp a b ,@(element-test world element-type))))) + =-name)) + + ; Create an equality comparison function for elements of the given :tag type. ; Return the name of the function and also set it in the type, the tag, and the :tag= property of the tag-name. (defun compute-tag-type-=-name (world type) @@ -1817,6 +1910,7 @@ (or (type-=-name type) (case (type-kind type) (:vector (compute-vector-type-=-name world type)) + (:list-set (compute-list-set-type-=-name world type)) (:tag (compute-tag-type-=-name world type)) (:union (setf (type-=-name type) 'union=) ;Must do this now to prevent runaway recursion. @@ -1879,7 +1973,7 @@ ; (expander preprocessor-state id arg1 arg2 ... argn) if property is :preprocess ; (expander world grammar-info-var arg1 arg2 ... argn) if property is :command ; (expander world type-env rest last id arg1 arg2 ... argn) if property is :statement -; (expander world type-env id arg1 arg2 ... argn) if property is :special-form +; (expander world type-env id arg1 arg2 ... argn) if property is :special-form or :condition ; (expander world allow-forward-references arg1 arg2 ... argn) if property is :type-constructor ; expander must be a function or a function symbol. ; @@ -1899,6 +1993,7 @@ (let ((emit-property (cdr (assoc property '((:command . :depict-command) (:statement . :depict-statement) (:special-form . :depict-special-form) + (:condition) (:type-constructor . :depict-type-constructor)))))) (assert-true (or emit-property (not depictor))) (assert-type symbol identifier) @@ -1960,7 +2055,7 @@ (unless (identifier? name) (error "~S should be an identifier" name)) (let ((symbol (world-intern world name))) - (when (get-properties (symbol-plist symbol) '(:command :statement :special-form :primitive :type-constructor)) + (when (get-properties (symbol-plist symbol) '(:command :statement :special-form :condition :primitive :type-constructor)) (error "~A is reserved" symbol)) symbol)) @@ -1993,7 +2088,11 @@ (defstruct (type-env-local (:type list) (:constructor make-type-env-local (name type mode))) name ;World-interned name of the local variable type ;That variable's type - mode) ;:const if the variable is read-only; :var if it's writable; :function if it's bound by flet; :unused if it's defined but shouldn't be used + mode) ;:const if the variable is read-only; +; ;:var if it's writable; +; ;:function if it's bound by flet; +; ;:reserved if it's bound by reserve; +; ;:unused if it's defined but shouldn't be used (defstruct (type-env-action (:type list) (:constructor make-type-env-action (key local-symbol type general-grammar-symbol))) key ;(action symbol . index) @@ -2037,7 +2136,7 @@ (assert-true (and (symbolp name) (type? type) - (member mode '(:const :var :function :unused)))) + (member mode '(:const :var :function :reserved :unused)))) (unless shadow (let ((binding (type-env-get-local type-env name))) (when binding @@ -2047,6 +2146,14 @@ (cons (make-type-env-local name type mode) type-env)) +; Define the reserved name as a :const binding. +(defun type-env-unreserve-binding (type-env name type) + (let ((binding (type-env-get-local type-env name))) + (unless (and binding (eq (type-env-local-mode binding) :reserved)) + (error "Local variable ~A:~A needs to be reserved first" name (print-type-to-string type))) + (type-env-add-binding type-env name type :const t))) + + ; Nondestructively shadow the type of the binding of name in type-env and return the new type-env. (defun type-env-narrow-binding (type-env name type) (let ((binding (assert-non-null (type-env-get-local type-env name)))) @@ -2089,6 +2196,12 @@ (cdr (assoc flag type-env))) +; Ensure that sub-type-env is derived from base-type-env. +(defun ensure-narrowed-type-env (base-type-env sub-type-env) + (unless (tailp base-type-env sub-type-env) + (error "The type environment ~S isn't narrower than ~S" sub-type-env base-type-env))) + + ;;; ------------------------------------------------------------------------------------------------------ ;;; VALUES @@ -2102,7 +2215,8 @@ ;;; A function (represented by a lisp function) ;;; A string ;;; A vector (represented by a list) -;;; A set (represented by an intset of its elements converted to integers) +;;; A list-set (represented by an unordered list of its elements) +;;; A range-set of integers or characters (represented by an intset of its elements converted to integers) ;;; A tag (represented by either a keyword or a list (keyword [serial-num] field-value1 ... field-value n)); ;;; serial-num is a unique integer present only on mutable tag instances. @@ -2146,21 +2260,26 @@ (:character (characterp value)) (:-> (functionp value)) (:string (stringp value)) - (:vector (let ((element-type (vector-element-type type))) - (labels - ((test (value) - (or (null value) - (and (consp value) - (or shallow (value-has-type (car value) element-type)) - (test (cdr value)))))) - (test value)))) - (:set (valid-intset? value)) + (:vector (value-list-has-type value (vector-element-type type) shallow)) + (:list-set (value-list-has-type value (set-element-type type) shallow)) + (:range-set (valid-intset? value)) (:tag (value-has-tag value (type-tag type) shallow)) (:union (some #'(lambda (subtype) (value-has-type value subtype shallow)) (type-parameters type))) (t (error "Bad typekind ~S" (type-kind type))))) +; Return true if the value is a list of elements that appear to have the given type. This function +; may return false positives (return true when the value doesn't actually +; have the given type) but never false negatives. +; If shallow is true, only check the list structure -- don't test that the elements have the given type. +(defun value-list-has-type (values type shallow) + (or (null values) + (and (consp values) + (or shallow (value-has-type (car values) type)) + (value-list-has-type (cdr values) type shallow)))) + + ; Print the value nicely on the given stream. type is the value's type. (defun print-value (value type &optional (stream t)) (assert-true (value-has-type value type t)) @@ -2178,18 +2297,29 @@ (print-value (pprint-pop) element-type stream) (pprint-exit-if-list-exhausted) (format stream " ~:_"))))) - (:set (let ((converter (set-out-converter (set-element-type type)))) - (pprint-logical-block (stream value :prefix "{" :suffix "}") - (pprint-exit-if-list-exhausted) - (loop - (let* ((values (pprint-pop)) - (value1 (car values)) - (value2 (cdr values))) - (if (= value1 value2) - (write (funcall converter value1) :stream stream) - (write (list (funcall converter value1) (funcall converter value2)) :stream stream)))) - (pprint-exit-if-list-exhausted) - (format stream " ~:_")))) + (:list-set + (let ((element-type (set-element-type type)) + (elements (if (eq (type-kind type) :list-set) + value + (hash-table-keys value)))) + (pprint-logical-block (stream elements :prefix "{" :suffix "}") + (pprint-exit-if-list-exhausted) + (loop + (print-value (pprint-pop) element-type stream) + (pprint-exit-if-list-exhausted) + (format stream " ~:_"))))) + (:range-set (let ((converter (range-set-out-converter (set-element-type type)))) + (pprint-logical-block (stream value :prefix "{" :suffix "}") + (pprint-exit-if-list-exhausted) + (loop + (let* ((values (pprint-pop)) + (value1 (car values)) + (value2 (cdr values))) + (if (= value1 value2) + (write (funcall converter value1) :stream stream) + (write (list (funcall converter value1) (funcall converter value2)) :stream stream)))) + (pprint-exit-if-list-exhausted) + (format stream " ~:_")))) (:tag (let ((tag (type-tag type))) (if (tag-keyword tag) (write value :stream stream) @@ -2345,7 +2475,7 @@ (values (list 'function (type-env-local-name symbol-binding)) (type-env-local-type symbol-binding) (list 'expr-annotation:local symbol))) - (:unused (error "Unused variable ~A referenced" symbol))) + ((:reserved :unused) (error "Unused variable ~A referenced" symbol))) (let ((primitive (symbol-primitive symbol))) (if primitive (values (primitive-value-code primitive) (primitive-type primitive) (list 'expr-annotation:primitive symbol)) @@ -2431,18 +2561,32 @@ (values value type annotated-expr))) -; Same as scan-value except that ensure that the value is a tag type. +; Same as scan-value except that ensure that the value is a set type. ; Return three values: ; The expression's value (a lisp expression) ; The expression's type ; The annotated value-expr -(defun scan-tag-value (world type-env value-expr) +(defun scan-set-value (world type-env value-expr) (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) - (unless (eq (type-kind type) :tag) - (error "Value ~S:~A should be a tag" value-expr (print-type-to-string type))) + (unless (member (type-kind type) '(:list-set :range-set)) + (error "Value ~S:~A should be a set" value-expr (print-type-to-string type))) (values value type annotated-expr))) +; Same as scan-value except that ensure that the value is a vector or set type. +; Return three values: +; The expression's value (a lisp expression) +; The expression's type kind +; The expression's element type +; The annotated value-expr +(defun scan-collection-value (world type-env value-expr) + (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) + (let ((kind (type-kind type))) + (unless (member kind '(:string :vector :list-set :range-set)) + (error "Value ~S:~A should be a vector or a set" value-expr (print-type-to-string type))) + (values value kind (collection-element-type type) annotated-expr)))) + + ; Same as scan-value except that ensure that the value is a tag type or a union of tag types. ; Return four values: ; The expression's value (a lisp expression) @@ -2453,20 +2597,39 @@ (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) (flet ((bad-type () (error "Value ~S:~A should be a tag or union of tags" value-expr (print-type-to-string type)))) - (let ((kind (type-kind type)) - (tags nil)) - (cond - ((eq kind :tag) - (setq tags (list (type-tag type)))) - ((eq kind :union) - (setq tags (mapcar #'(lambda (type2) (if (eq (type-kind type2) :tag) - (type-tag type2) - (bad-type))) - (type-parameters type)))) - (t (bad-type))) + (let ((tags nil)) + (case (type-kind type) + (:tag + (setq tags (list (type-tag type)))) + (:union + (setq tags (mapcar #'(lambda (type2) (if (eq (type-kind type2) :tag) + (type-tag type2) + (bad-type))) + (type-parameters type)))) + (t (bad-type))) (values value type tags annotated-expr))))) +; Generate a lisp expression that will compute the boolean condition expression in condition-expr. +; type-env is the type environment. The expression may refer to free variables present in the type-env. +; Return four values: +; The code for the condition; +; The annotated code for the condition; +; A type-env to use if the condition is true; +; A type-env to use if the condition is false. +(defun scan-condition (world type-env condition-expr) + (when (consp condition-expr) + (let ((first (first condition-expr))) + (when (identifier? first) + (let* ((symbol (world-intern world first)) + (handler (get symbol :condition))) + (when handler + (return-from scan-condition (assert-four-values (apply handler world type-env symbol (rest condition-expr))))))))) + (multiple-value-bind (condition-code condition-annotated-expr) + (scan-typed-value world type-env condition-expr (world-boolean-type world)) + (values condition-code condition-annotated-expr type-env type-env))) + + ; Return the code for computing value-expr, which will be assigned to the symbol. Check that the ; value has the given type. (defun scan-global-value (symbol value-expr type) @@ -2647,21 +2810,21 @@ (orders-and-exprs (cddr orders-and-exprs))) (multiple-value-bind (code2 annotated-expr2) (scan-typed-value world type-env expr2 type) (if orders-and-exprs - (let ((v2 (gensym "L"))) + (let ((v2 (gen-local-var code2))) (multiple-value-bind (codes annotations) (cascade v2 orders-and-exprs) (values - `(let ((,v2 ,code2)) - (and ,(get-type-order-code world type order v1 v2) ,codes)) + (let-local-var v2 code2 + `(and ,(get-type-order-code world type order v1 v2) ,codes)) (list* order-name annotated-expr2 annotations)))) (values (get-type-order-code world type order v1 code2) (list order-name annotated-expr2))))))) (multiple-value-bind (code1 annotated-expr1) (scan-typed-value world type-env expr1 type) - (let ((v1 (gensym "L"))) + (let ((v1 (gen-local-var code1))) (multiple-value-bind (codes annotations) (cascade v1 orders-and-exprs) (values - `(let ((,v1 ,code1)) ,codes) + (let-local-var v1 code1 codes) (world-boolean-type world) (list* 'expr-annotation:special-form special-form annotated-expr1 annotations)))))))) @@ -2692,6 +2855,59 @@ (list* 'expr-annotation:special-form special-form op annotated-exprs)))) +; (not ) +(defun scan-not-condition (world type-env special-form expr) + (multiple-value-bind (expr-code expr-annotated-expr expr-true-type-env expr-false-type-env) + (scan-condition world type-env expr) + (values + (list 'not expr-code) + (list 'expr-annotation:call (list 'expr-annotation:primitive special-form) expr-annotated-expr) + expr-false-type-env + expr-true-type-env))) + + +; (and ... ) +; Short-circuiting logical AND. +(defun scan-and-condition (world type-env special-form expr &rest exprs) + (multiple-value-bind (code1 annotated-expr1 true-type-env false-type-env) + (scan-condition world type-env expr) + (let ((codes (list code1)) + (annotated-exprs (list annotated-expr1))) + (dolist (expr2 exprs) + (multiple-value-bind (code2 annotated-expr2 true-type-env2 false-type-env2) + (scan-condition world true-type-env expr2) + (push code2 codes) + (push annotated-expr2 annotated-exprs) + (setq true-type-env true-type-env2) + (ensure-narrowed-type-env false-type-env false-type-env2))) + (values + (gen-poly-op 'and t (nreverse codes)) + (list* 'expr-annotation:special-form special-form 'and (nreverse annotated-exprs)) + true-type-env + false-type-env)))) + + +; (or ... ) +; Short-circuiting logical OR. +(defun scan-or-condition (world type-env special-form expr &rest exprs) + (multiple-value-bind (code1 annotated-expr1 true-type-env false-type-env) + (scan-condition world type-env expr) + (let ((codes (list code1)) + (annotated-exprs (list annotated-expr1))) + (dolist (expr2 exprs) + (multiple-value-bind (code2 annotated-expr2 true-type-env2 false-type-env2) + (scan-condition world false-type-env expr2) + (push code2 codes) + (push annotated-expr2 annotated-exprs) + (setq false-type-env false-type-env2) + (ensure-narrowed-type-env true-type-env true-type-env2))) + (values + (gen-poly-op 'or nil (nreverse codes)) + (list* 'expr-annotation:special-form special-form 'or (nreverse annotated-exprs)) + true-type-env + false-type-env)))) + + ; (begin . ) ; Only allowed at the top level of an action. @@ -2766,10 +2982,10 @@ ; (if ) (defun scan-if-expr (world type-env special-form condition-expr true-expr false-expr) - (multiple-value-bind (condition-code condition-annotated-expr) - (scan-typed-value world type-env condition-expr (world-boolean-type world)) - (multiple-value-bind (true-code true-type true-annotated-expr) (scan-value world type-env true-expr) - (multiple-value-bind (false-code false-type false-annotated-expr) (scan-value world type-env false-expr) + (multiple-value-bind (condition-code condition-annotated-expr true-type-env false-type-env) + (scan-condition world type-env condition-expr) + (multiple-value-bind (true-code true-type true-annotated-expr) (scan-value world true-type-env true-expr) + (multiple-value-bind (false-code false-type false-annotated-expr) (scan-value world false-type-env false-expr) (handler-bind (((or error warning) #'(lambda (condition) (declare (ignore condition)) @@ -2778,7 +2994,9 @@ false-expr (print-type-to-string false-type))))) (let ((type (type-union world true-type false-type))) (values - (list 'if condition-code true-code false-code) + (list 'if condition-code + (widening-coercion-code world type true-type true-code condition-expr) + (widening-coercion-code world type false-type false-code condition-expr)) type (list 'expr-annotation:special-form special-form condition-annotated-expr true-annotated-expr false-annotated-expr)))))))) @@ -2825,45 +3043,6 @@ (make-vector-expr world special-form element-type element-codes element-annotated-exprs)))) -; (empty ) -; Returns true if the vector has zero elements. -; This is equivalent to (= (length ) 0) and depicts the same as the latter but -; is implemented more efficiently. -(defun scan-empty (world type-env special-form vector-expr) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) - (values - (if (eq vector-type (world-string-type world)) - `(= (length ,vector-code) 0) - (list 'endp vector-code)) - (world-boolean-type world) - (list 'expr-annotation:special-form special-form vector-annotated-expr)))) - - -; (nonempty ) -; Returns true if the vector does not have zero elements. -; This is equivalent to (/= (length ) 0) and depicts the same as the latter but -; is implemented more efficiently. -(defun scan-nonempty (world type-env special-form vector-expr) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) - (values - (if (eq vector-type (world-string-type world)) - `(/= (length ,vector-code) 0) - vector-code) - (world-boolean-type world) - (list 'expr-annotation:special-form special-form vector-annotated-expr)))) - - -; (length ) -; Returns the number of elements in the vector. -(defun scan-length (world type-env special-form vector-expr) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) - (declare (ignore vector-type)) - (values - (list 'length vector-code) - (world-integer-type world) - (list 'expr-annotation:special-form special-form vector-annotated-expr)))) - - ; (nth ) ; Returns the nth element of the vector. Throws an error if the vector's length is less than n. (defun scan-nth (world type-env special-form vector-expr n-expr) @@ -2875,9 +3054,9 @@ `(char ,vector-code ,n-code)) ((eql n-code 0) `(car (non-empty-vector ,vector-code "first"))) - (t (let ((n (gensym "N"))) - `(let ((,n ,n-code)) - (car (non-empty-vector (nthcdr ,n ,vector-code) "nth")))))) + (t (let ((n (gen-local-var n-code))) + (let-local-var n n-code + `(car (non-empty-vector (nthcdr ,n ,vector-code) "nth")))))) (vector-element-type vector-type) (list 'expr-annotation:special-form special-form vector-annotated-expr n-annotated-expr))))) @@ -2947,81 +3126,76 @@ (list 'expr-annotation:special-form special-form vector-annotated-expr n-annotated-expr value-annotated-expr)))))) -; (map []) -(defun scan-map (world type-env special-form vector-expr var-source value-expr &optional (condition-expr 'true)) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) - (let* ((var (scan-name world var-source)) - (element-type (vector-element-type vector-type)) - (local-type-env (type-env-add-binding type-env var element-type :const))) - (multiple-value-bind (value-code value-type value-annotated-expr) (scan-value world local-type-env value-expr) - (multiple-value-bind (condition-code condition-annotated-expr) (scan-typed-value world local-type-env condition-expr (world-boolean-type world)) - (let* ((result-type (make-vector-type world value-type)) - (source-is-string (eq element-type (world-character-type world))) - (destination-is-string (eq value-type (world-character-type world))) - (destination-sequence-type (if destination-is-string 'string 'list)) - (result-annotated-expr (list 'expr-annotation:special-form special-form vector-annotated-expr var value-annotated-expr condition-annotated-expr))) - (cond - ((eq condition-code 't) - (values - (if (or source-is-string destination-is-string) - `(map ',destination-sequence-type #'(lambda (,var) ,value-code) ,vector-code) - `(mapcar #'(lambda (,var) ,value-code) ,vector-code)) - result-type - (nbutlast result-annotated-expr))) - ((eq value-expr var-source) - (assert-true (eq value-type element-type)) - (values - `(remove-if-not #'(lambda (,var) ,condition-code) ,vector-code) - result-type - result-annotated-expr)) - (t - (values - (if (or source-is-string destination-is-string) - `(filter-map ',destination-sequence-type #'(lambda (,var) ,condition-code) #'(lambda (,var) ,value-code) ,vector-code) - `(filter-map-list #'(lambda (,var) ,condition-code) #'(lambda (,var) ,value-code) ,vector-code)) - result-type - result-annotated-expr))))))))) - - ;;; Sets -; Return a function that converts values of the given element-type to integers for storage in a set. -(defun set-in-converter (element-type) - (ecase (type-kind element-type) - (:integer #'identity) - (:character #'char-code))) +(defun make-list-set-expr (world special-form element-type element-codes element-annotated-exprs) + (values + (cond + ((endp element-codes) nil) + ((endp (cdr element-codes)) (cons 'list element-codes)) + (t `(delete-duplicates (list ,@element-codes) ,@(element-test world element-type)))) + (make-list-set-type world element-type) + (list* 'expr-annotation:special-form special-form element-annotated-exprs))) + +; (list-set ... ) +; Makes a set of one or more elements. +(defun scan-list-set-expr (world type-env special-form element-expr &rest element-exprs) + (multiple-value-bind (element-code element-type element-annotated-expr) (scan-value world type-env element-expr) + (multiple-value-map-bind (rest-codes rest-annotated-exprs) + #'(lambda (element-expr) + (scan-typed-value world type-env element-expr element-type)) + (element-exprs) + (make-list-set-expr world special-form element-type (cons element-code rest-codes) (cons element-annotated-expr rest-annotated-exprs))))) + +; (list-set-of ... ) +; Makes a set of zero or more elements of the given type. +(defun scan-list-set-of (world type-env special-form element-type-expr &rest element-exprs) + (let ((element-type (scan-type world element-type-expr))) + (multiple-value-map-bind (element-codes element-annotated-exprs) + #'(lambda (element-expr) + (scan-typed-value world type-env element-expr element-type)) + (element-exprs) + (make-list-set-expr world special-form element-type element-codes element-annotated-exprs)))) ; expr is the source code of an expression that generates a value of the given element-type. Return -; the source code of an expression that generates the corresponding integer for storage in a set of +; the source code of an expression that generates the corresponding integer for storage in a range-set of ; the given element-type. -(defun set-in-converter-expr (element-type expr) +(defun range-set-in-converter-expr (element-type expr) (ecase (type-kind element-type) (:integer expr) (:character (list 'char-code expr)))) -; Return a function that converts integers to values of the given element-type for retrieval from a set. -(defun set-out-converter (element-type) +; expr is the source code of an expression that generates an integer. Return the source code that undoes +; the transformation done by range-set-in-converter-expr. +(defun range-set-out-converter-expr (element-type expr) + (ecase (type-kind element-type) + (:integer expr) + (:character (list 'code-char expr)))) + + +; Return a function that converts integers to values of the given element-type for retrieval from a range-set. +(defun range-set-out-converter (element-type) (ecase (type-kind element-type) (:integer #'identity) (:character #'code-char))) -; (set-of ... ) ==> -; (set-of-ranges nil ... nil) -(defun scan-set-of (world type-env special-form element-type-expr &rest element-exprs) - (apply #'scan-set-of-ranges +; (range-set-of ... ) ==> +; (range-set-of-ranges nil ... nil) +(defun scan-range-set-of (world type-env special-form element-type-expr &rest element-exprs) + (apply #'scan-range-set-of-ranges world type-env special-form element-type-expr (mapcan #'(lambda (element-expr) (list element-expr nil)) element-exprs))) -; (set-of-ranges ... ) +; (range-set-of-ranges ... ) ; Makes a set of zero or more elements or element ranges. Each can be null to indicate a ; one-element range. -(defun scan-set-of-ranges (world type-env special-form element-type-expr &rest element-exprs) +(defun scan-range-set-of-ranges (world type-env special-form element-type-expr &rest element-exprs) (let* ((element-type (scan-type world element-type-expr)) (high t)) (multiple-value-map-bind (element-codes element-annotated-exprs) @@ -3031,47 +3205,289 @@ (values nil nil) (multiple-value-bind (element-code element-annotated-expr) (scan-typed-value world type-env element-expr element-type) - (values (set-in-converter-expr element-type element-code) + (values (range-set-in-converter-expr element-type element-code) element-annotated-expr)))) (element-exprs) (unless high - (error "Odd number of set-of-ranges elements: ~S" element-exprs)) + (error "Odd number of range-set-of-ranges elements: ~S" element-exprs)) (values (cons 'intset-from-ranges element-codes) - (make-set-type world element-type) - (list* 'expr-annotation:special-form special-form element-type-expr element-annotated-exprs))))) + (make-range-set-type world element-type) + (list* 'expr-annotation:special-form special-form element-annotated-exprs))))) -;;; Tags +; (set* ) +; Returns the intersection of the two sets, which must have the same kind. +(defun scan-set* (world type-env special-form set1-expr set2-expr) + (multiple-value-bind (set1-code set-type set1-annotated-expr) (scan-set-value world type-env set1-expr) + (multiple-value-bind (set2-code set2-annotated-expr) (scan-typed-value world type-env set2-expr set-type) + (values + (ecase (type-kind set-type) + (:list-set (list* 'intersection set1-code set2-code (element-test world (set-element-type set-type)))) + (:range-set (list 'intset-intersection set1-code set2-code))) + set-type + (list 'expr-annotation:special-form special-form set1-annotated-expr set2-annotated-expr))))) -(defparameter *tag-counter* 0) -; (tag ... ) -(defun scan-tag-expr (world type-env special-form tag-name &rest value-exprs) - (let* ((tag (scan-tag world tag-name)) - (type (make-tag-type world tag)) +; (set+ ) +; Returns the union of the two sets, which must have the same kind. +(defun scan-set+ (world type-env special-form set1-expr set2-expr) + (multiple-value-bind (set1-code set-type set1-annotated-expr) (scan-set-value world type-env set1-expr) + (multiple-value-bind (set2-code set2-annotated-expr) (scan-typed-value world type-env set2-expr set-type) + (values + (ecase (type-kind set-type) + (:list-set (list* 'union set1-code set2-code (element-test world (set-element-type set-type)))) + (:range-set (list 'intset-union set1-code set2-code))) + set-type + (list 'expr-annotation:special-form special-form set1-annotated-expr set2-annotated-expr))))) + + +; (set- ) +; Returns the difference of the two sets, which must have the same kind. +(defun scan-set- (world type-env special-form set1-expr set2-expr) + (multiple-value-bind (set1-code set-type set1-annotated-expr) (scan-set-value world type-env set1-expr) + (multiple-value-bind (set2-code set2-annotated-expr) (scan-typed-value world type-env set2-expr set-type) + (values + (ecase (type-kind set-type) + (:list-set (list* 'set-difference set1-code set2-code (element-test world (set-element-type set-type)))) + (:range-set (list 'intset-difference set1-code set2-code))) + set-type + (list 'expr-annotation:special-form special-form set1-annotated-expr set2-annotated-expr))))) + + +; (set-in ) +; Returns true if is a member of the set . +(defun scan-set-in (world type-env special-form elt-expr set-expr) + (multiple-value-bind (set-code set-type set-annotated-expr) (scan-set-value world type-env set-expr) + (let ((elt-type (set-element-type set-type))) + (multiple-value-bind (elt-code elt-annotated-expr) (scan-typed-value world type-env elt-expr elt-type) + (values + (ecase (type-kind set-type) + (:list-set (list* 'member elt-code set-code (element-test world elt-type))) + (:range-set (list 'intset-member? (range-set-in-converter-expr elt-type elt-code) set-code))) + (world-boolean-type world) + (list 'expr-annotation:special-form special-form :member-10 elt-annotated-expr set-annotated-expr)))))) + + +; (set-not-in ) +; Returns true if is not a member of the set . +(defun scan-set-not-in (world type-env special-form elt-expr set-expr) + (multiple-value-bind (set-code set-type set-annotated-expr) (scan-set-value world type-env set-expr) + (let ((elt-type (set-element-type set-type))) + (multiple-value-bind (elt-code elt-annotated-expr) (scan-typed-value world type-env elt-expr elt-type) + (values + (ecase (type-kind set-type) + (:list-set (list 'not (list* 'member elt-code set-code (element-test world elt-type)))) + (:range-set (list 'not (list 'intset-member? (range-set-in-converter-expr elt-type elt-code) set-code)))) + (world-boolean-type world) + (list 'expr-annotation:special-form special-form :not-member-10 elt-annotated-expr set-annotated-expr)))))) + + +(defun elt-of (set) + (if set + (car set) + (error "elt-of called on empty set"))) + +(defun range-set-elt-of (set) + (or (intset-min set) + (error "elt-of called on empty set"))) + +; (elt-of ) +; Returns any element of , which must be a nonempty set. +(defun scan-elt-of (world type-env special-form set-expr) + (multiple-value-bind (set-code set-type set-annotated-expr) (scan-set-value world type-env set-expr) + (let ((elt-type (set-element-type set-type))) + (values + (ecase (type-kind set-type) + (:list-set (list 'elt-of set-code)) + (:range-set (range-set-out-converter-expr elt-type (list 'range-set-elt-of set-code)))) + elt-type + (list 'expr-annotation:special-form special-form set-annotated-expr))))) + + +;;; Vectors or Sets + +; (empty ) +; Returns true if the vector or set has zero elements. +; This is equivalent to (= (length ) 0) but is implemented more efficiently. +(defun scan-empty (world type-env special-form collection-expr) + (multiple-value-bind (collection-code collection-kind element-type collection-annotated-expr) (scan-collection-value world type-env collection-expr) + (declare (ignore element-type)) + (values + (ecase collection-kind + (:string `(zerop (length ,collection-code))) + ((:vector :list-set) (list 'endp collection-code)) + (:range-set (list 'intset-empty collection-code))) + (world-boolean-type world) + (list 'expr-annotation:special-form special-form collection-kind collection-annotated-expr)))) + + +; (nonempty ) +; Returns true if the vector or set does not have zero elements. +; This is equivalent to (/= (length ) 0) but is implemented more efficiently. +(defun scan-nonempty (world type-env special-form collection-expr) + (multiple-value-bind (collection-code collection-kind element-type collection-annotated-expr) (scan-collection-value world type-env collection-expr) + (declare (ignore element-type)) + (values + (ecase collection-kind + (:string `(/= (length ,collection-code) 0)) + ((:vector :list-set) collection-code) + (:range-set `(not (intset-empty ,collection-code)))) + (world-boolean-type world) + (list 'expr-annotation:special-form special-form collection-kind collection-annotated-expr)))) + + +; (length ) +; Returns the number of elements in the vector or set. +(defun scan-length (world type-env special-form collection-expr) + (multiple-value-bind (collection-code collection-kind element-type collection-annotated-expr) (scan-collection-value world type-env collection-expr) + (declare (ignore element-type)) + (values + (ecase collection-kind + ((:string :vector :list-set) (list 'length collection-code)) + (:range-set (list 'intset-length collection-code))) + (world-integer-type world) + (list 'expr-annotation:special-form special-form collection-annotated-expr)))) + + +; (some ) +; Return true if there exists an element of on which is true. +; Not implemented on range-sets. +(defun scan-some (world type-env special-form collection-expr var-source condition-expr) + (multiple-value-bind (code annotated-expr true-type-env false-type-env) + (scan-some-condition world type-env special-form collection-expr var-source condition-expr) + (declare (ignore true-type-env false-type-env)) + (values code (world-boolean-type world) annotated-expr))) + + +; (some [:define-true]) +; Return true if there exists an element of on which is true. +; If :define-true is given, set to be any such element (the first if in a vector) in the true branch; must have been reserved. +; Not implemented on range-sets. +(defun scan-some-condition (world type-env special-form collection-expr var-source condition-expr &optional define-true) + (unless (member define-true '(nil :define-true)) + (error "~S must be :define-true")) + (multiple-value-bind (collection-code collection-kind element-type collection-annotated-expr) (scan-collection-value world type-env collection-expr) + (unless (member collection-kind '(:vector :string :list-set)) + (error "Not implemented")) + (let* ((var (scan-name world var-source)) + (local-type-env (if define-true + (type-env-unreserve-binding type-env var element-type) + (type-env-add-binding type-env var element-type :const)))) + (multiple-value-bind (condition-code condition-annotated-expr) (scan-typed-value world local-type-env condition-expr (world-boolean-type world)) + (let ((result-annotated-expr (list 'expr-annotation:special-form special-form 'some collection-annotated-expr var condition-annotated-expr)) + (coerced-collection-code (if (eq collection-kind :string) `(coerce ,collection-code 'list) collection-code))) + (if define-true + (values + (let ((v (gensym "V"))) + `(dolist (,v ,coerced-collection-code) + (when (let ((,var ,v)) ,condition-code) + (setq ,var ,v) + (return t)))) + result-annotated-expr + local-type-env + type-env) + (values + `(some #'(lambda (,var) ,condition-code) ,coerced-collection-code) + result-annotated-expr + type-env + type-env))))))) + + +; (every ) +; Return true if every element in satisfies . +; Not implemented on range-sets. +(defun scan-every (world type-env special-form collection-expr var-source condition-expr) + (multiple-value-bind (collection-code collection-kind element-type collection-annotated-expr) (scan-collection-value world type-env collection-expr) + (unless (member collection-kind '(:vector :string :list-set)) + (error "Not implemented")) + (let* ((var (scan-name world var-source)) + (local-type-env (type-env-add-binding type-env var element-type :const))) + (multiple-value-bind (condition-code condition-annotated-expr) (scan-typed-value world local-type-env condition-expr (world-boolean-type world)) + (let ((coerced-collection-code (if (eq collection-kind :string) `(coerce ,collection-code 'list) collection-code))) + (values + `(every #'(lambda (,var) ,condition-code) ,coerced-collection-code) + (world-boolean-type world) + (list 'expr-annotation:special-form special-form 'every collection-annotated-expr var condition-annotated-expr))))))) + + +; (map []) +; Return a vector or set of applied to all elements of on which is true. +; The map produces a vector if given a vector or a list-set if given a list-set. +; Not implemented on range-sets. +(defun scan-map (world type-env special-form collection-expr var-source value-expr &optional (condition-expr 'true)) + (multiple-value-bind (collection-code collection-kind element-type collection-annotated-expr) (scan-collection-value world type-env collection-expr) + (let* ((var (scan-name world var-source)) + (local-type-env (type-env-add-binding type-env var element-type :const))) + (multiple-value-bind (value-code value-type value-annotated-expr) (scan-value world local-type-env value-expr) + (multiple-value-bind (condition-code condition-annotated-expr) (scan-typed-value world local-type-env condition-expr (world-boolean-type world)) + (let* ((source-is-vector (member collection-kind '(:string :vector))) + (source-is-string (eq collection-kind :string)) + (destination-is-string (and source-is-vector (eq value-type (world-character-type world)))) + (result-type (ecase collection-kind + ((:string :vector) (make-vector-type world value-type)) + (:list-set (make-list-set-type world value-type)) + (:range-set (error "Map not implemented on range-sets")))) + (destination-sequence-type (if destination-is-string 'string 'list)) + (result-annotated-expr (list 'expr-annotation:special-form special-form collection-kind collection-annotated-expr var value-annotated-expr condition-annotated-expr))) + (cond + ((eq condition-code 't) + (values + (let ((mapcar-code `(mapcar #'(lambda (,var) ,value-code) ,collection-code))) + (cond + ((or source-is-string destination-is-string) `(map ',destination-sequence-type ,@(cdr mapcar-code))) + (source-is-vector mapcar-code) + (t (list* 'delete-duplicates mapcar-code (element-test world value-type))))) + result-type + (nbutlast result-annotated-expr))) + ((eq value-expr var-source) + (assert-true (eq value-type element-type)) + (values + `(remove-if-not #'(lambda (,var) ,condition-code) ,collection-code) + result-type + result-annotated-expr)) + (t + (values + (let ((filter-map-list-code `(filter-map-list #'(lambda (,var) ,condition-code) #'(lambda (,var) ,value-code) ,collection-code))) + (cond + ((or source-is-string destination-is-string) `(filter-map ',destination-sequence-type ,@(cdr filter-map-list-code))) + (source-is-vector filter-map-list-code) + (t (list* 'delete-duplicates filter-map-list-code (element-test world value-type))))) + result-type + result-annotated-expr))))))))) + + +;;; Tuples and Records + +(defparameter *record-counter* 0) + +; (new ... ) +; Used to create both tuples and records. +(defun scan-new (world type-env special-form type-name &rest value-exprs) + (let* ((type (scan-kinded-type world type-name :tag)) + (tag (type-tag type)) (fields (tag-fields tag))) (unless (= (length value-exprs) (length fields)) - (error "Wrong number of ~A fields given in constructor: ~S" tag-name value-exprs)) + (error "Wrong number of ~A fields given in constructor: ~S" type-name value-exprs)) + (when (tag-keyword tag) + (error "Don't use new to create tag ~A; refer to the tag directly instead" type-name)) (multiple-value-map-bind (value-codes value-annotated-exprs) #'(lambda (field value-expr) (scan-typed-value world type-env value-expr (field-type field))) (fields value-exprs) (values - (or (tag-keyword tag) - (let ((name (tag-name tag))) - (if (tag-mutable tag) - (list* 'list (list 'quote name) '(incf *tag-counter*) value-codes) - (list* 'list (list 'quote name) value-codes)))) + (let ((name (tag-name tag))) + (if (tag-mutable tag) + (list* 'list (list 'quote name) '(incf *record-counter*) value-codes) + (list* 'list (list 'quote name) value-codes))) type - (list* 'expr-annotation:special-form special-form tag value-annotated-exprs))))) + (list* 'expr-annotation:special-form special-form type type-name value-annotated-exprs))))) ; (&