diff --git a/js2/semantics/Calculus.lisp b/js2/semantics/Calculus.lisp index 1ba819777bc..95a51301cdc 100644 --- a/js2/semantics/Calculus.lisp +++ b/js2/semantics/Calculus.lisp @@ -23,24 +23,29 @@ ;;; Waldemar Horwat (waldemar@acm.org) ;;; +(declaim (optimize (debug 3))) ;***** (defvar *trace-variables* nil) -#+mcl (dolist (indent-spec '((? . 1) (apply . 1) (funcall . 1) (production . 3) (rule . 2) (function . 1) (letexc . 1) (deftype . 1) (tuple . 1) (%text . 1))) +#+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))) (pushnew indent-spec ccl:*fred-special-indent-alist* :test #'equal)) -; A strict version of and. -(defun and2 (a b) - (and a b)) +; Return the boolean exclusive or of the arguments. +(defun xor (&rest as) + (let ((result nil)) + (dolist (a as) + (when a + (setq result (not result)))) + result)) -; A strict version of or. -(defun or2 (a b) - (or a b)) -; A strict version of xor. -(defun xor2 (a b) - (or (and a (not b)) (and (not a) b))) +; A boolean version of = that works on any nil/non-nil values. +(declaim (inline boolean=)) +(defun boolean= (a b) + (eq (not a) (not b))) ; Complement of eq. @@ -74,32 +79,44 @@ (coerce result-type (nreverse results)))) +; Return the same symbol in the keyword package. +(defun find-keyword (symbol) + (assert-non-null (find-symbol (string symbol) (find-package :keyword)))) + + ;;; ------------------------------------------------------------------------------------------------------ ;;; DOUBLE-PRECISION FLOATING-POINT NUMBERS (deftype float64 () - '(or float (member :+inf :-inf :nan))) + '(or (and float (not (eql 0.0)) (not (eql -0.0))) (member :+zero :-zero :+inf :-inf :nan))) (defun float64? (n) - (or (floatp n) - (member n '(:+inf :-inf :nan)))) + (or (and (floatp n) (not (zerop n))) + (member n '(:+zero :-zero :+inf :-inf :nan)))) -; Evaluate expr. If it evaluates successfully, return its values. -; If not, evaluate sign; if it returns a positive value, return :+inf; +; Evaluate expr. If it evaluates successfully, return its value except if it evaluates to +; +0.0 or -0.0, in which case return :+zero (but not :-zero). +; If evaluating expr overflows, evaluate sign; if it returns a positive value, return :+inf; ; otherwise return :-inf. sign should not return zero. (defmacro handle-overflow (expr &body sign) - `(handler-case ,expr - (floating-point-overflow () (if (minusp (progn ,@sign)) :-inf :+inf)))) + (let ((x (gensym))) + `(handler-case (let ((,x ,expr)) + (if (zerop ,x) :+zero ,x)) + (floating-point-overflow () (if (minusp (progn ,@sign)) :-inf :+inf))))) (defun rational-to-float64 (r) - (handle-overflow (coerce r 'double-float) r)) + (let ((f (handle-overflow (coerce r 'double-float) + r))) + (if (eq f :+zero) + (if (minusp r) :-zero :+zero) + f))) ; Return true if n is +0 or -0 and false otherwise. (declaim (inline float64-is-zero)) (defun float64-is-zero (n) - (and (floatp n) (zerop n))) + (or (eq n :+zero) (eq n :-zero))) ; Return true if n is NaN and false otherwise. @@ -114,12 +131,30 @@ (or (eq n :+inf) (eq n :-inf))) +; Convert n to a rational number. Signal an error if n isn't finite. +(defun float64-to-rational (n) + (if (float64-is-zero n) + 0 + (rational n))) + + +; Truncate n to the next lower integer. Signal an error if n isn't finite. +(defun truncate-float64 (n) + (if (float64-is-zero n) + 0 + (truncate n))) + + ; Return: ; less if nm; ; unordered if either n or m is :nan. (defun float64-compare (n m less equal greater unordered) + (when (float64-is-zero n) + (setq n 0.0)) + (when (float64-is-zero m) + (setq m 0.0)) (cond ((or (float64-is-nan n) (float64-is-nan m)) unordered) ((eql n m) equal) @@ -136,15 +171,12 @@ ; 0 if n is :nan. (defun float64-sign (n) (case n - (:+inf 1) - (:-inf -1) + ((:+zero :+inf) 1) + ((:-zero :-inf) -1) (:nan 0) (t (round (float-sign n))))) -(assert-true (and (= (float64-sign 0.0) 1) (= (float64-sign -0.0) -1))) - - ; Return ; 0 if either n or m is :nan; ; 1 if n and m have the same float64-sign; @@ -156,13 +188,14 @@ ; Return d truncated towards zero into a 32-bit integer. Overflows wrap around. (defun float64-to-uint32 (d) (case d - ((:+inf :-inf :nan) 0) + ((:+zero :-zero :+inf :-inf :nan) 0) (t (mod (truncate d) #x100000000)))) ; Return the absolute value of n. (defun float64-abs (n) (case n + ((:+zero :-zero) :+zero) ((:+inf :-inf) :+inf) (:nan :nan) (t (abs n)))) @@ -171,6 +204,8 @@ ; Return -n. (defun float64-neg (n) (case n + (:+zero :-zero) + (:-zero :+zero) (:+inf :-inf) (:-inf :+inf) (:nan :nan) @@ -180,16 +215,17 @@ ; Return n+m. (defun float64-add (n m) (case n + (:+zero (if (eq m :-zero) :+zero m)) + (:-zero m) (:+inf (case m - (:-inf :nan) - (:nan :nan) + ((:-inf :nan) :nan) (t :+inf))) (:-inf (case m - (:+inf :nan) - (:nan :nan) + ((:+inf :nan) :nan) (t :-inf))) (:nan :nan) (t (case m + ((:+zero :-zero) n) (:+inf :+inf) (:-inf :-inf) (:nan :nan) @@ -212,8 +248,9 @@ (m (float64-abs m))) (let ((result (cond ((zerop sign) :nan) - ((eq n :+inf) (if (float64-is-zero m) :nan :+inf)) - ((eq m :+inf) (if (float64-is-zero n) :nan :+inf)) + ((eq n :+inf) (if (eq m :+zero) :nan :+inf)) + ((eq m :+inf) (if (eq n :+zero) :nan :+inf)) + ((or (eq n :+zero) (eq m :+zero)) :+zero) (t (handle-overflow (* n m) 1))))) (if (minusp sign) (float64-neg result) @@ -228,8 +265,9 @@ (let ((result (cond ((zerop sign) :nan) ((eq n :+inf) (if (eq m :+inf) :nan :+inf)) - ((eq m :+inf) 0d0) - ((zerop m) (if (zerop n) :nan :+inf)) + ((eq m :+inf) :+zero) + ((eq m :+zero) (if (eq n :+zero) :nan :+inf)) + ((eq n :+zero) :+zero) (t (handle-overflow (/ n m) 1))))) (if (minusp sign) (float64-neg result) @@ -241,7 +279,10 @@ (cond ((or (float64-is-nan n) (float64-is-nan m) (float64-is-infinite n) (float64-is-zero m)) :nan) ((or (float64-is-infinite m) (float64-is-zero n)) n) - (t (float (rem (rational n) (rational m)))))) + (t (let ((result (float (rem (rational n) (rational m))))) + (if (zerop result) + (if (minusp n) :-zero :+zero) + result))))) ;;; ------------------------------------------------------------------------------------------------------ @@ -275,25 +316,74 @@ ;;; ------------------------------------------------------------------------------------------------------ ;;; CODE GENERATION +#+mcl(defvar *deferred-functions*) + +(defun quiet-compile (name definition) + #-mcl(compile name definition) + #+mcl(handler-bind ((ccl::undefined-function-reference + #'(lambda (condition) + (setq *deferred-functions* (append (slot-value condition 'ccl::args) *deferred-functions*)) + (muffle-warning condition)))) + (compile name definition))) + + +(defmacro defer-mcl-warnings (&body body) + #-mcl`(with-compilation-unit () ,@body) + #+mcl`(let ((*deferred-functions* nil)) + (multiple-value-prog1 + (with-compilation-unit () ,@body) + (let ((missing-functions (remove-if #'fboundp *deferred-functions*))) + (when missing-functions + (warn "Undefined functions: ~S" missing-functions)))))) + + +; If args has no elements, return the value of empty. +; If args has one element, return that element. +; If args has two or more elements, return (op . args). +(defun gen-poly-op (op empty args) + (cond + ((endp args) empty) + ((endp (cdr args)) (car args)) + (t (cons op args)))) + + ; Return `(progn ,@statements), optimizing where possible. -(defun gen-progn (&rest statements) - (if (and (= (length statements) 1) - (let ((first-statement (first statements))) - (not (and (consp first-statement) - (eq (first first-statement) 'declare))))) - (first statements) - (cons 'progn statements))) +(defun gen-progn (statements) + (cond + ((endp statements) nil) + ((and (endp (cdr statements)) + (let ((first-statement (first statements))) + (not (and (consp first-statement) + (eq (first first-statement) 'declare))))) + (first statements)) + (t (cons 'progn statements)))) + + +; Return (nth ), optimizing if possible. +(defun gen-nth-code (n code) + (let ((abbrev (assoc n '((0 . first) (1 . second) (2 . third) (3 . fourth) (4 . fifth) (5 . sixth) (6 . seventh) (7 . eighth) (8 . ninth) (9 . tenth))))) + (if abbrev + (list (cdr abbrev) code) + (list 'nth n code)))) + + +; Return code that tests whether the result of evaluating code is a member of the given +; list of symbols using the test eq. +(defun gen-member-test (code symbols) + (assert-true symbols) + (if (cdr symbols) + (list 'member code (list 'quote symbols) :test '#'eq) + (list 'eq code (let ((symbol (car symbols))) + (if (constantp symbol) + symbol + (list 'quote symbol)))))) ; Return `(funcall ,function-value ,@arg-values), optimizing where possible. (defun gen-apply (function-value &rest arg-values) - (cond - ((and (consp function-value) - (eq (first function-value) 'function) - (consp (rest function-value)) - (second function-value) - (null (cddr function-value))) - (let ((stripped-function-value (second function-value))) + (let ((stripped-function-value (simple-strip-function function-value))) + (cond + (stripped-function-value (if (and (consp stripped-function-value) (eq (first stripped-function-value) 'lambda) (listp (second stripped-function-value)) @@ -309,17 +399,17 @@ (list* 'let (mapcar #'list function-args arg-values) function-body) - (apply #'gen-progn function-body))) - (cons stripped-function-value arg-values)))) - ((and (consp function-value) - (eq (first function-value) 'symbol-function) - (null (cddr function-value)) - (consp (cadr function-value)) - (eq (caadr function-value) 'quote) - (identifier? (cadadr function-value)) - (null (cddadr function-value))) - (cons (cadadr function-value) arg-values)) - (t (list* 'funcall function-value arg-values)))) + (gen-progn function-body))) + (cons stripped-function-value arg-values))) + ((and (consp function-value) + (eq (first function-value) 'symbol-function) + (null (cddr function-value)) + (consp (cadr function-value)) + (eq (caadr function-value) 'quote) + (identifier? (cadadr function-value)) + (null (cddadr function-value))) + (cons (cadadr function-value) arg-values)) + (t (list* 'funcall function-value arg-values))))) ; Return `#'(lambda ,args (declare (ignore-if-unused ,@args)) ,body-code), optimizing @@ -390,6 +480,16 @@ (list 'defun name args (apply #'gen-apply expr args))))) +; If code has the form (function ), return ; otherwise, return nil. +(defun simple-strip-function (code) + (when (and (consp code) + (eq (first code) 'function) + (consp (rest code)) + (second code) + (null (cddr code))) + (assert-non-null (second code)))) + + ; Strip the (function ...) covering from expr, leaving only a plain lambda expression. (defun strip-function (expr name n-args) (when (special-form-p name) @@ -514,18 +614,23 @@ (:predicate world?)) (conditionals nil :type list) ;Assoc list of (conditional . highlight), where highlight can be a style keyword, nil (no style), or 'delete (package nil :type package) ;The package in which this world's identifiers are interned - (n-type-names 0 :type integer) ;Number of type names defined so far - (types-reverse nil :type (or null hash-table)) ;Hash table of (kind tags parameters) -> type; nil if invalid - (oneof-tags nil :type (or null hash-table)) ;Hash table of (oneof-tag . field-type) -> (must-be-unique oneof-type ... oneof-type); nil if invalid + (next-type-serial-number 0 :type integer) ;Serial number to be used for the next type defined + (types-reverse nil :type (or null hash-table)) ;Hash table of (kind tag parameters) -> type; nil if invalid + (false-tag nil :type (or null tag)) ;Tag used for false + (true-tag nil :type (or null tag)) ;Tag used for true (bottom-type nil :type (or null type)) ;Subtype of all types used for nonterminating computations (void-type nil :type (or null type)) ;Type used for placeholders + (false-type nil :type (or null type)) ;Type used for false + (true-type nil :type (or null type)) ;Type used for true (boolean-type nil :type (or null type)) ;Type used for booleans (integer-type nil :type (or null type)) ;Type used for integers (rational-type nil :type (or null type)) ;Type used for rational numbers - (float64-type nil :type (or null type)) ;Type used for double-precision floating-point numbers - (id-type nil :type (or null type)) ;Type used for id's + (finite64-type nil :type (or null type)) ;Type used for nonzero finite double-precision floating-point numbers (character-type nil :type (or null type)) ;Type used for characters (string-type nil :type (or null type)) ;Type used for strings (vectors of characters) + (denormalized-false-type nil :type (or null type)) ;Type (denormalized-tag false) + (denormalized-true-type nil :type (or null type)) ;Type (denormalized-tag true) + (boxed-boolean-type nil :type (or null type)) ;Union type (union (tag true) (tag false)) (grammar-infos nil :type list) ;List of grammar-info (commands-source nil :type list)) ;List of source code of all commands applied to this world @@ -575,8 +680,7 @@ (let* ((p (make-package name :use nil)) (world (allocate-world :package p - :types-reverse (make-hash-table :test #'equal) - :oneof-tags (make-hash-table :test #'equal))) + :types-reverse (make-hash-table :test #'equal))) (access-symbol (intern "*WORLD*" p))) (set access-symbol world) (export access-symbol p) @@ -701,57 +805,67 @@ ;;; ;;; :command expression code generation function ((world grammar-info-var . form-arg-list) -> void) if this identifier ;;; is a command like 'deftype or 'define +;;; :statement expression code generation function ((world type-env rest last id . form-arg-list) -> codes, live, annotated-stmts) +;;; if this identifier is a statement like 'if or 'catch; +;;; codes is a list of generated statements, live is true if the statement can fall through, and +;;; 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 'if or 'function +;;; if this identifier is a special form like 'tag or 'in ;;; ;;; :primitive primitive structure if this identifier is a primitive ;;; -;;; :macro lisp expansion function ((world type-env . form-arg-list) -> expansion) if this identifier is a macro -;;; ;;; :type-constructor expression code generation function ((world allow-forward-references . form-arg-list) -> type) if this -;;; identifier is a type constructor like '->, 'vector, 'set, 'tuple, 'oneof, or 'address +;;; identifier is a type constructor like '->, 'vector, '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 -> ;;; value of this identifier if it is a variable of type -> -;;; :code lisp code that was evaluated to produce ;;; :value-expr unparsed expression defining the value of this identifier if it is a variable ;;; :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= 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 ;;; ;;; :depict-command depictor function ((markup-stream world depict-env . form-arg-list) -> void) -;;; :depict-type-constructor depictor function ((markup-stream world level . form-arg-list) -> void) +;;; :depict-statement depictor function ((markup-stream world . form-annotated-arg-list) -> void) ;;; :depict-special-form depictor function ((markup-stream world level . form-annotated-arg-list) -> void) -;;; :depict-macro depictor function ((markup-stream world level . form-annotated-arg-list) -> void) +;;; :depict-type-constructor depictor function ((markup-stream world level . form-arg-list) -> void) ;;; -; Return the code of the value associated with the given symbol or default if none. -; This macro is appropriate for use with setf. -(defmacro symbol-code (symbol &optional default) - `(get ,symbol :code ,@(and default (list default)))) - - ; Return the preprocessor action associated with the given symbol or nil if none. ; This macro is appropriate for use with setf. (defmacro symbol-preprocessor-function (symbol) `(get ,symbol :preprocess)) -; Return the macro definition associated with the given symbol or nil if none. -; This macro is appropriate for use with setf. -(defmacro symbol-macro (symbol) - `(get ,symbol :macro)) - - ; Return the primitive definition associated with the given symbol or nil if none. ; This macro is appropriate for use with setf. (defmacro symbol-primitive (symbol) `(get ,symbol :primitive)) +; Return the tag definition associated with the given symbol or nil if none. +; This macro is appropriate for use with setf. +(defmacro symbol-tag (symbol) + `(get ,symbol :tag)) + + +; Call f on each tag definition in the world. +; f takes two arguments: +; the name +; the tag structure +(defun each-tag-definition (world f) + (each-world-external-symbol-with-property world :tag f)) + + +; Return a sorted list of the names of all tag definitions in the world. +(defun world-tag-definitions (world) + (all-world-external-symbols-with-property world :tag)) + + ; Return the type definition associated with the given symbol. ; Return nil if the symbol is a forward-referenced type. ; If the symbol has no type definition at all, return default @@ -787,12 +901,6 @@ `(get ,symbol :type)) -; Return true if there is a variable associated with the given symbol. -(declaim (inline symbol-has-variable)) -(defun symbol-has-variable (symbol) - (not (eq (get symbol *get2-nonce*) *get2-nonce*))) - - ; Return a list of (grammar-info . grammar-symbol) pairs that each indicate ; a grammar and a grammar-symbol in that grammar that has an action named by the given symbol. ; This macro is appropriate for use with setf. @@ -800,46 +908,174 @@ `(get ,symbol :action)) +; Return an unused name for a new function in the world. The given string is a suggested name. +; The returned value is a symbol. +(defun unique-function-name (world string) + (let ((f (world-intern world string))) + (if (fboundp f) + (gentemp string (world-package world)) + f))) + + +;;; ------------------------------------------------------------------------------------------------------ +;;; TAGS + +(defstruct (field (:type list) (:constructor make-field (label type mutable))) + label ;This field's name (not interned in the world) + type ;This field's type + mutable) ;True if this fields is mutable + + +(defstruct (tag (:constructor make-tag (name keyword mutable fields =-name link)) (:predicate tag?)) + (name nil :type symbol :read-only t) ;This tag's world-interned name + (keyword nil :type (or null keyword) :read-only t) ;This tag's keyword (non-null only when the tag is immutable and has no fields) + (mutable nil :type bool :read-only t) ;True if this tag's equality is based on identity, in which case the tag's values have a hidden serial-number field + (fields nil :type list :read-only t) ;List of fields after eval-tags-types or (field-name field-type-expression [:const|:var]) before eval-tags-types + (=-name nil :type symbol) ;Lazily computed name of a function that compares two values of this tag for equality; nil if not known yet + (link nil :type (or null keyword) :read-only t)) ;:reference if this is a local tag, :external if it's a predefined tag, or nil for no cross-references to this tag + +; Return three values: +; the one-based position of the tag'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 tag-find-field (tag label) + (do ((fields (tag-fields tag) (cdr fields)) + (n (if (tag-mutable tag) 2 1) (1+ n))) + ((endp fields) (values nil nil nil)) + (let ((field (car fields))) + (when (eq label (field-label field)) + (return (values n (field-type field) (field-mutable field))))))) + + +; 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) + (assert-true (member link '(nil :reference :external))) + (let ((name (scan-name world name))) + (when (symbol-tag name) + (error "Attempt to redefine tag ~A" name)) + (let ((keyword nil) + (=-name nil)) + (unless (or mutable fields) + (setq keyword (intern (string name) :keyword))) + (when (or mutable (null fields)) + (setq =-name 'eq) + (setf (get name :tag=) #'eq)) + (let ((tag (make-tag name keyword mutable fields =-name link))) + (setf (symbol-tag name) tag) + (export-symbol name) + tag)))) + + +; Evaluate the type expressions in the tag's fields. +(defun eval-tag-types (world tag) + (do ((fields (tag-fields tag) (cdr fields)) + (labels nil)) + ((endp fields)) + (let ((field (first fields))) + (unless (and (consp field) (identifier? (first field)) + (consp (cdr field)) (second field) + (member (third field) '(nil :const :var)) + (null (cdddr field))) + (error "Bad field ~S" field)) + (let ((label (first field)) + (mutable (eq (third field) :var))) + (when (member label labels) + (error "Duplicate label ~S" label)) + (push label labels) + (when (and mutable (not (tag-mutable tag))) + (error "Tag ~S is immutable but contains a mutable field ~S" (tag-name tag) label)) + (setf (first fields) (make-field label (scan-type world (second field)) mutable)))))) + + +; Evaluate the type expressions in all of the world's tag's fields. +(defun eval-tags-types (world) + (each-tag-definition + world + #'(lambda (name tag) + (declare (ignore name)) + (eval-tag-types world tag)))) + + +; 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)))) + + +; Scan label to produce a label that is present in the given tag. +; Return the label's position, its field type, and a flag indicating whether it is mutable. +(defun scan-label (tag label) + (multiple-value-bind (position field-type mutable) (tag-find-field tag label) + (unless position + (error "Label ~S not present in ~A" label (tag-name tag))) + (values position field-type mutable))) + + +; Print the tag nicely on the given stream. +(defun print-tag (tag &optional (stream t)) + (pprint-logical-block (stream (tag-fields tag) :prefix "(" :suffix ")") + (pprint-exit-if-list-exhausted) + (loop + (let ((field (pprint-pop))) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (write (field-label field) :stream stream) + (format stream " ~@_") + (print-type (field-type field) stream) + (when (field-mutable field) + (format stream " ~@_t"))) + (pprint-exit-if-list-exhausted) + (format stream " ~:_"))))) + + ;;; ------------------------------------------------------------------------------------------------------ ;;; TYPES (deftype typekind () - '(member ;tags ;parameters + '(member ;tag ;parameters :bottom ;nil ;nil :void ;nil ;nil :boolean ;nil ;nil :integer ;nil ;nil :rational ;nil ;nil - :float64 ;nil ;nil - :id ;nil ;nil + :finite64 ;nil ;nil ;All non-zero finite 64-bit double-precision floating-point numbers :character ;nil ;nil :-> ;nil ;(result-type arg1-type arg2-type ... argn-type) + :string ;nil ;(character) :vector ;nil ;(element-type) :set ;nil ;(element-type) - :tuple ;(tag1 ... tagn) ;(element1-type ... elementn-type) - :oneof ;(tag1 ... tagn) ;(element1-type ... elementn-type) - :address)) ;nil ;(element-type) + :tag ;tag ;nil + :denormalized-tag ;tag ;nil + :union)) ;nil ;(type ... type) sorted by ascending serial numbers + +;A denormalized-tag is a singleton tag type whose value carries no meaning. +; +;All types are normalized except for those with kind :denormalized-tag and the boxed-boolean union type of tags true and false. +; +;A union type must have: +; at least two types +; only types with kinds :integer, :rational, :finite64, :character, :string, or :tag +; no type that is a duplicate or subtype of another type in the union +; types sorted by ascending type-serial-number. +; +;Note that types with the above kinds never change their serial-numbers during unite-types, so +;unite-types does not need to worry about unions differing only in the order of their parameters. -; Return true if typekind1 is the same or more specific (i.e. a subtype) than typekind2. -(defun typekind<= (typekind1 typekind2) - (or (eq typekind1 typekind2) - (eq typekind1 :bottom) - (and (eq typekind1 :integer) (eq typekind2 :rational)))) - - -(defstruct (type (:constructor allocate-type (kind tags parameters)) - (:predicate type?)) +(defstruct (type (:constructor allocate-type (serial-number kind tag parameters =-name /=-name)) (:predicate type?)) (name nil :type symbol) ;This type's name; nil if this type is anonymous - (name-serial-number nil :type (or null integer)) ;This type's name's serial number; nil if this type is anonymous + (serial-number nil :type integer) ;This type's unique serial number (kind nil :type typekind :read-only t) ;This type's kind - (tags nil :type list :read-only t) ;List of tuple or oneof tags - (parameters nil :type list :read-only t)) ;List of parameter types (either types or symbols if forward-referenced) describing a compound type + (tag nil :type (or null tag) :read-only t) ;This type's tag + (parameters nil :type list :read-only t) ;List of parameter types (either types or symbols if forward-referenced) describing a compound type + (=-name nil :type symbol) ;Lazily computed name of a function that compares two values of this type for equality; nil if not known yet + (/=-name nil :type symbol)) ;Name of a function that complements = or nil if none (declaim (inline make-->-type)) (defun make-->-type (world argument-types result-type) - (make-type world :-> nil (cons result-type argument-types))) + (make-type world :-> nil (cons result-type argument-types) nil nil)) (declaim (inline ->-argument-types)) (defun ->-argument-types (type) @@ -854,17 +1090,19 @@ (declaim (inline make-vector-type)) (defun make-vector-type (world element-type) - (make-type world :vector nil (list element-type))) + (if (eq element-type (world-character-type world)) + (world-string-type world) + (make-type world :vector nil (list element-type) nil nil))) (declaim (inline vector-element-type)) (defun vector-element-type (type) - (assert-true (eq (type-kind type) :vector)) + (assert-true (member (type-kind type) '(:vector :string))) (car (type-parameters type))) (declaim (inline make-set-type)) (defun make-set-type (world element-type) - (make-type world :set nil (list element-type))) + (make-type world :set nil (list element-type) 'intset= nil)) (declaim (inline set-element-type)) (defun set-element-type (type) @@ -872,53 +1110,358 @@ (car (type-parameters type))) -; Return the type of the oneof's or tuple's field corresponding to the given tag -; or nil if the tag is not present in the oneof's or tuple's tags. -(defun field-type (type tag) - (assert-true (member (type-kind type) '(:oneof :tuple))) - (let ((pos (position tag (type-tags type)))) - (and pos (nth pos (type-parameters type))))) +(declaim (inline make-tag-type)) +(defun make-tag-type (world tag) + (make-type world :tag tag nil (tag-=-name tag) nil)) -(declaim (inline make-address-type)) -(defun make-address-type (world element-type) - (make-type world :address nil (list element-type))) +(declaim (inline always-true)) +(defun always-true (a b) + (declare (ignore a b)) + t) -(declaim (inline address-element-type)) -(defun address-element-type (type) - (assert-true (eq (type-kind type) :address)) - (car (type-parameters type))) +(declaim (inline always-false)) +(defun always-false (a b) + (declare (ignore a b)) + nil) + +(declaim (inline make-denormalized-tag-type)) +(defun make-denormalized-tag-type (world tag) + (assert-true (tag-keyword tag)) + (make-type world :denormalized-tag tag nil 'always-true 'always-false)) -; Return true if type1 is the same or more specific (i.e. a subtype) than type2. -(defun type<= (type1 type2) - (or (eq type1 type2) +; 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)) + + +; Equivalent types are guaranteed to be eq to each other. +(declaim (inline type=)) +(defun type= (type1 type2) + (eq type1 type2)) + + +; Convert a value of a union type that includes finite64 into a value of a union type that includes rational. +(defun union-finite64-to-rational (value) + (if (floatp value) + (rational value) + value)) + + +; code is a lisp expression that evaluates to either :true or :false. +; Return a lisp expression that evaluates code and returns either t or nil. +(defun bool-unboxing-code (code) + (if (constantp code) + (ecase code + (:true t) + (:false nil)) + (list 'eq code :true))) + + +; code is a lisp expression that evaluates to either non-nil or nil. +; Return a lisp expression that evaluates code and returns either :true or :false. +(defun bool-boxing-code (code) + (if (constantp code) + (ecase code + ((t) :true) + ((nil) :false)) + (list 'if code :true :false))) + + +; code is a lisp expression that evaluates to a value of type type. +; If type is the same or more specific (i.e. a subtype) than supertype, return code that evaluates code +; and returns its value coerced to supertype. +; Signal an error if type is not a subtype of supertype. expr contains the source code that generated code +; and is used for error reporting only. +; +; Coercions from :denormalized-tag types are not implemented, but they should not be necessary in practice. +(defun widening-coercion-code (world supertype type code expr) + (if (type= type supertype) + code + (flet ((type-mismatch () + (error "Expected type ~A for ~:W but got type ~A" + (print-type-to-string supertype) + expr + (print-type-to-string type)))) + (let ((kind (type-kind type))) + (if (eq kind :bottom) + code + (case (type-kind supertype) + (:boolean + (if (or (type= type (world-false-type world)) + (type= type (world-true-type world)) + (type= type (world-boxed-boolean-type world))) + (bool-unboxing-code code) + (type-mismatch))) + (:rational + (case kind + (:integer code) + (:finite64 (list 'rational code)) + (t (type-mismatch)))) + (:union + (let ((supertype-types (type-parameters supertype))) + (case kind + (:boolean + (if (and (member (world-false-type world) supertype-types) (member (world-true-type world) supertype-types)) + (bool-boxing-code code) + (type-mismatch))) + (:integer + (if (or (member type supertype-types) (member (world-rational-type world) supertype-types)) + code + (type-mismatch))) + ((:rational :character :string :tag) + (if (member type supertype-types) + code + (type-mismatch))) + (:finite64 + (cond + ((member type supertype-types) code) + ((member (world-rational-type world) supertype-types) (list 'rational code)) + (t (type-mismatch)))) + (:union + (let ((convert-finite64-to-rational nil)) + (dolist (type-type (type-parameters type)) + (unless (case (type-kind type-type) + (:integer (or (member type-type supertype-types) (member (world-rational-type world) supertype-types))) + ((:rational :character :string :tag) (member type-type supertype-types)) + (:finite64 + (or (member type-type supertype-types) + (and (member (world-rational-type world) supertype-types) (setq convert-finite64-to-rational t))))) + (type-mismatch))) + (if convert-finite64-to-rational + (list 'union-finite64-to-rational code) + code))) + (t (type-mismatch))))) + (t (type-mismatch)))))))) + + +; Return the list of constituent types that the given type would have if it were a union. +; The result is sorted by ascending serial numbers and contains no duplicates. +(defun type-to-union (world type) + (ecase (type-kind type) + (:boolean (type-parameters (world-boxed-boolean-type world))) + ((:integer :rational :finite64 :character :string :tag) (list type)) + (:denormalized-tag (make-tag-type world (type-tag type))) + (:union (type-parameters type)))) + + +; Merge the two lists of types sorted by ascending serial numbers. +; The result is also sorted by ascending serial numbers and contains no duplicates. +(defun merge-type-lists (types1 types2) + (cond + ((endp types1) types2) + ((endp types2) types1) + (t (let ((type1 (first types1)) + (type2 (first types2))) + (if (type= type1 type2) + (cons type1 (merge-type-lists (rest types1) (rest types2))) + (let ((serial-number1 (type-serial-number type1)) + (serial-number2 (type-serial-number type2))) + (assert-true (/= serial-number1 serial-number2)) + (if (< serial-number1 serial-number2) + (cons type1 (merge-type-lists (rest types1) types2)) + (cons type2 (merge-type-lists types1 (rest types2)))))))))) + + +; Return true if the list of types is sorted by serial number. +(defun type-list-sorted (types) + (let ((n (type-serial-number (first types)))) + (dolist (type (rest types) t) + (let ((n2 (type-serial-number type))) + (unless (< n n2) + (return nil)) + (setq n n2))))) + + +(defun coercable-to-union-kind (kind) + (member kind '(:boolean :integer :rational :finite64 :character :string :tag :denormalized-tag :union))) + + +; types is a list of distinct, non-overlapping types appropriate for inclusion in a union and +; sorted by increasing serial numbers. Return the union type for holding types, reducing it to +; a simpler type as necessary. If normalize is nil, don't change the representation of the destination type. +(defun reduce-union-type (world types normalize) + (cond + ((endp types) (world-bottom-type world)) + ((endp (cdr types)) (car types)) + ((and (endp (cddr types)) (member (world-true-type world) types) (member (world-false-type world) types)) + (if normalize + (world-boolean-type world) + (world-boxed-boolean-type world))) + ((every #'(lambda (type) (eq (type-=-name type) 'eq)) types) + (make-type world :union nil types 'eq nil)) + ((every #'(lambda (type) (member (type-=-name type) '(eq eql = char=))) types) + (make-type world :union nil types 'eql nil)) + (t (make-type world :union nil types nil nil)))) + + +; Return the union of type1 and type2. +(defun type-union (world type1 type2) + (labels + ((numeric-kind (kind) + (member kind '(:integer :rational :finite64))) + (numeric-type (type) + (numeric-kind (type-kind type)))) + (if (type= type1 type2) + type1 (let ((kind1 (type-kind type1)) (kind2 (type-kind type2))) - (or (eq kind1 :bottom) - (and (eq kind1 :integer) (eq kind2 :rational)) - (and (eq kind1 :->) (eq kind2 :->) - ; For now we require the argument types to match exactly. - (equal (->-argument-types type1) (->-argument-types type2)) - ; This might fall into an infinite loop, but it's OK for now. - (type<= (->-result-type type1) (->-result-type type2))))))) + (cond + ((eq kind1 :bottom) type2) + ((eq kind2 :bottom) type1) + ((and (numeric-kind kind1) (numeric-kind kind2)) (world-rational-type world)) + ((and (coercable-to-union-kind kind1) (coercable-to-union-kind kind2)) + (let ((types (merge-type-lists (type-to-union world type1) (type-to-union world type2)))) + (when (> (count-if #'numeric-type types) 1) + ;Currently the union of any two or more different numeric types is always rational. + (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))) + (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 type1 and type2 or nil if there is none. -(defun type-lub (type1 type2) - (cond - ((type<= type1 type2) type2) - ((type<= type2 type1) type1) - (t nil))) +; Return the most specific common supertype of the types. +(defun make-union-type (world &rest types) + (if types + (reduce #'(lambda (type1 type2) (type-union world type1 type2)) + types) + (world-bottom-type world))) -; Return true if serial-number-1 is less than serial-number-2. -; Each serial-number is either an integer or nil, which is considered to -; be positive infinity. -(defun serial-number-< (serial-number-1 serial-number-2) - (and serial-number-1 - (or (null serial-number-2) - (< serial-number-1 serial-number-2)))) +; 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. +; subtype2, the type containing the instances of type but not subtype. +; Any concrete value of type will have either subtype1 or subtype2 without needing coercion. +; subtype1 and subtype2 may be denormalized in the following cases: +; type is boolean and subtype is (tag true) or (tag false); +; type is a union and subtype is boolean. +; Signal an error if there is no subtype2. +(defun type-difference (world type subtype) + (flet ((type-mismatch () + (error "Cannot subtract type ~A from type ~A" (print-type-to-string subtype) (print-type-to-string type)))) + (if (type= type subtype) + (if (type= subtype (world-bottom-type world)) + (type-mismatch) + (values type (world-bottom-type world))) + (case (type-kind type) + (:boolean + (cond + ((or (type= subtype (world-false-type world)) (type= subtype (world-denormalized-false-type world))) + (values (world-denormalized-false-type world) (world-denormalized-true-type world))) + ((or (type= subtype (world-true-type world)) (type= subtype (world-denormalized-true-type world))) + (values (world-denormalized-true-type world) (world-denormalized-false-type world))) + ((type= subtype (world-boxed-boolean-type world)) + (values type (world-bottom-type world))) + (t (type-mismatch)))) + (:tag + (if (and (eq (type-kind subtype) :denormalized-tag) (eq (type-tag type) (type-tag subtype))) + (values type (world-bottom-type world)) + (type-mismatch))) + (:denormalized-tag + (if (and (eq (type-kind subtype) :tag) (eq (type-tag type) (type-tag subtype))) + (values type (world-bottom-type world)) + (type-mismatch))) + (:union + (let ((types (type-parameters type))) + (flet + ((remove-subtype (subtype) + (unless (member subtype types) + (type-mismatch)) + (setq types (remove subtype types)))) + (case (type-kind subtype) + (:boolean + (remove-subtype (world-false-type world)) + (remove-subtype (world-true-type world)) + (setq subtype (world-boxed-boolean-type world))) + (:union + (mapc #'remove-subtype (type-parameters subtype))) + (:denormalized-tag + (remove-subtype (make-tag-type world (type-tag subtype)))) + (t (remove-subtype subtype))) + (values subtype (reduce-union-type world types nil))))) + (t (type-mismatch)))))) + + + +; types must be a list of types suitable for inclusion in a :union type's parameters. Return the following values: +; a list of integerp, rationalp, floatp, characterp, and/or stringp, depending on whether types include the +; :integer, :rational, :finite64, :character, and/or :string member kinds; +; a list of keywords used by non-list tags in the types; +; a list of tag names used by list tags in the types +(defun analyze-union-types (types) + (let ((atom-tests nil) + (keywords nil) + (list-tag-names nil)) + (dolist (type types) + (ecase (type-kind type) + (:integer (push 'integerp atom-tests)) + (:rational (push 'rationalp atom-tests)) + (:finite64 (push 'floatp atom-tests)) + (:character (push 'characterp atom-tests)) + (:string (push 'stringp atom-tests)) + (:tag (let* ((tag (type-tag type)) + (keyword (tag-keyword tag))) + (if keyword + (push keyword keywords) + (push (tag-name tag) list-tag-names)))))) + (values + (nreverse atom-tests) + (nreverse keywords) + (nreverse list-tag-names)))) + + +; code is a lisp expression that evaluates to a value of type type. subtype is a subtype of type, which +; has already been verified by calling type-difference. +; Return a lisp expression that may evaluate code and returns non-nil if the value is a member of the subtype. +; The expression may evaluate code more than once or not at all. +(defun type-member-test-code (world subtype type code) + (if (type= type subtype) + t + (ecase (type-kind type) + (:boolean + (cond + ((or (type= subtype (world-false-type world)) (type= subtype (world-denormalized-false-type world))) + (list 'not code)) + ((or (type= subtype (world-true-type world)) (type= subtype (world-denormalized-true-type world))) + code) + (t (error "Bad type-member-test-code")))) + ((:tag :denormalized-tag) t) + (:union + (multiple-value-bind (type-atom-tests type-keywords type-list-tag-names) (analyze-union-types (type-parameters type)) + (multiple-value-bind (subtype-atom-tests subtype-keywords subtype-list-tag-names) + (case (type-kind subtype) + (:boolean (values nil (list :false :true) nil)) + (:union (analyze-union-types (type-parameters subtype))) + (:denormalized-tag (analyze-union-types (list (make-tag-type world (type-tag subtype))))) + (t (analyze-union-types (list subtype)))) + (assert-true (and (subsetp subtype-atom-tests type-atom-tests) + (subsetp subtype-keywords type-keywords) + (subsetp subtype-list-tag-names type-list-tag-names))) + (gen-poly-op 'or nil + (nconc + (mapcar #'(lambda (atom-test) (list atom-test code)) subtype-atom-tests) + (and subtype-keywords (list (gen-member-test code subtype-keywords))) + (and subtype-list-tag-names + (list (gen-poly-op 'and t + (nconc + (and (or type-atom-tests type-keywords) (list (list 'consp code))) + (list (gen-member-test (list 'car code) subtype-list-tag-names)))))))))))))) + + + +; Return true if type1's serial-number is less than type2's serial-number; +; however, unnamed types' serial numbers are considered to be positive infinity. +(defun type-named-serial-number-< (type1 type2) + (let ((name1 (if (type-name type1) 0 1)) + (name2 (if (type-name type2) 0 1))) + (or (< name1 name2) + (and (= name1 name2) + (< (type-serial-number type1) (type-serial-number type2)))))) ; Print the type nicely on the given stream. If expand1 is true then print @@ -927,57 +1470,45 @@ (defun print-type (type &optional (stream t) expand1) (if (and (type-name type) (not expand1)) (write-string (symbol-name (type-name type)) stream) - (labels - ((print-tuple-or-oneof (kind-string) - (pprint-logical-block (stream (mapcar #'cons (type-tags type) (type-parameters type)) - :prefix "(" :suffix ")") - (write-string kind-string stream) - (pprint-exit-if-list-exhausted) - (format stream " ~@_") - (pprint-indent :current 0 stream) - (loop - (let ((tag-and-type (pprint-pop))) - (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (write (car tag-and-type) :stream stream) - (format stream " ~@_") - (print-type (cdr tag-and-type) stream)) + (case (type-kind type) + (:bottom (write-string "bottom" stream)) + (:void (write-string "void" stream)) + (:boolean (write-string "boolean" stream)) + (:integer (write-string "integer" stream)) + (:rational (write-string "rational" stream)) + (:finite64 (write-string "finite64" stream)) + (:character (write-string "character" stream)) + (:-> (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (format stream "-> ~@_") + (pprint-indent :current 0 stream) + (pprint-logical-block (stream (->-argument-types type) :prefix "(" :suffix ")") (pprint-exit-if-list-exhausted) - (format stream " ~:_"))) - (format stream " ~_") - (print-type (->-result-type type) stream)))) - - (case (type-kind type) - (:bottom (write-string "bottom" stream)) - (:void (write-string "void" stream)) - (:boolean (write-string "boolean" stream)) - (:integer (write-string "integer" stream)) - (:rational (write-string "rational" stream)) - (:float64 (write-string "float64" stream)) - (:id (write-string "id" stream)) - (:character (write-string "character" stream)) - (:-> (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (format stream "-> ~@_") - (pprint-indent :current 0 stream) - (pprint-logical-block (stream (->-argument-types type) :prefix "(" :suffix ")") + (loop + (print-type (pprint-pop) stream) (pprint-exit-if-list-exhausted) - (loop - (print-type (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (format stream " ~:_"))) - (format stream " ~_") - (print-type (->-result-type type) stream))) - (: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))) - (:tuple (print-tuple-or-oneof "tuple")) - (:oneof (print-tuple-or-oneof "oneof")) - (:address (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (format stream "address ~@_") - (print-type (address-element-type type) stream))) - (t (error "Bad typekind ~S" (type-kind type))))))) + (format stream " ~:_"))) + (format stream " ~_") + (print-type (->-result-type type) stream))) + (:string (write-string "string" stream)) + (: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))) + (:tag (let ((tag (type-tag type))) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (format stream "tag ~@_~A" (tag-name tag))))) + (:union (pprint-logical-block (stream (type-parameters type) :prefix "(" :suffix ")") + (write-string "union" stream) + (pprint-exit-if-list-exhausted) + (format stream " ~@_") + (pprint-indent :current 0 stream) + (loop + (print-type (pprint-pop) stream) + (pprint-exit-if-list-exhausted) + (format stream " ~:_")))) + (t (error "Bad typekind ~S" (type-kind type)))))) ; Same as print-type except that accumulates the output in a string @@ -989,61 +1520,21 @@ (defmethod print-object ((type type) stream) (print-unreadable-object (type stream) - (format stream "type ~@_") + (format stream "type~D ~@_" (type-serial-number type)) (let ((name (type-name type))) (when name (format stream "~A = ~@_" name))) (print-type type stream t))) -; Register all of the oneof type's tags in the world's oneof-tags hash table. -; The hash table is indexed by pairs (tag . field-type) and is used to look up a -; oneof type given just a tag and its field's type. The data in the hash table -; consists of lists (flag oneof-type ... oneof-type). The flag is true if such a -; lookup has been performed (in which case the data must contain exactly one oneof-type -; and it is an error to add another one). -(defun register-oneof-tags (world oneof-type) - (let ((oneof-tags-hash (world-oneof-tags world))) - (mapc #'(lambda (tag field-type) - (let* ((key (cons tag field-type)) - (data (gethash key oneof-tags-hash))) - (cond - ((null data) - (setf (gethash key oneof-tags-hash) (list nil oneof-type))) - ((not (car data)) - (push oneof-type (cdr data))) - (t (error "Ambiguous oneof lookup of tag ~A: ~A. Possibilities are ~A or ~A" - tag - (print-type-to-string field-type) - (print-type-to-string (second data)) - (print-type-to-string oneof-type)))))) - (type-tags oneof-type) - (type-parameters oneof-type)))) - - -; Look up a oneof type given one of its tags and the corresponding field type. -; Signal an error if there is no such type or there is more than one matching type. -(defun lookup-oneof-tag (world tag field-type) - (let ((data (gethash (cons tag field-type) (world-oneof-tags world)))) - (cond - ((null data) - (error "No known oneof type with tag ~A: ~A" tag (print-type-to-string field-type))) - ((cddr data) - (error "Ambiguous oneof lookup of tag ~A: ~A. Possibilities are ~S" tag (print-type-to-string field-type) (cdr data))) - (t - (setf (first data) t) - (second data))))) - - -; Create or reuse a type with the given kind, tags, and parameters. -; A type is reused if one already exists with equal kind, tags, and parameters. +; Create or reuse a type with the given kind, tag, and parameters. +; A type is reused if one already exists with equal kind, tag, and parameters. ; Return the type. -(defun make-type (world kind tags parameters) - (let ((reverse-key (list kind tags parameters))) +(defun make-type (world kind tag parameters =-name /=-name) + (let ((reverse-key (list kind tag parameters))) (or (gethash reverse-key (world-types-reverse world)) - (let ((type (allocate-type kind tags parameters))) - (when (eq kind :oneof) - (register-oneof-tags world type)) + (let ((type (allocate-type (world-next-type-serial-number world) kind tag parameters =-name /=-name))) + (incf (world-next-type-serial-number world)) (setf (gethash reverse-key (world-types-reverse world)) type))))) @@ -1056,9 +1547,7 @@ (error "Attempt to redefine type ~A" symbol)) ;If the old type was anonymous, give it this name. (unless (type-name type) - (setf (type-name type) symbol) - (setf (type-name-serial-number type) (world-n-type-names world))) - (incf (world-n-type-names world)) + (setf (type-name type) symbol)) (setf (symbol-type-definition symbol) type) (when user-defined (setf (symbol-type-user-defined symbol) t)) @@ -1091,7 +1580,7 @@ type-expr) (t (let ((type-constructor (and (consp type-expr) (symbolp (first type-expr)) - (get (world-intern world (first type-expr)) :type-constructor)))) + (get (world-find-symbol world (first type-expr)) :type-constructor)))) (if type-constructor (apply type-constructor world allow-forward-references (rest type-expr)) (error "Bad type ~S" type-expr)))))) @@ -1125,47 +1614,20 @@ (make-set-type world (scan-type world element-type allow-forward-references))) -; (address ) -(defun scan-address (world allow-forward-references element-type) - (make-address-type world (scan-type world element-type allow-forward-references))) +; (tag ... ) +(defun scan-tag-type (world allow-forward-references tag-name &rest tag-names) + (if tag-names + (apply #'make-union-type world (mapcar #'(lambda (tag-name) + (scan-tag-type world allow-forward-references tag-name)) + (cons tag-name tag-names))) + (make-tag-type world (scan-tag world tag-name)))) -(defun scan-tuple-or-oneof (world allow-forward-references kind tag-pairs tags-so-far types-so-far) - (if tag-pairs - (let ((tag-pair (car tag-pairs))) - (when (and (identifier? tag-pair) (eq kind :oneof)) - (setq tag-pair (list tag-pair 'void))) - (unless (and (consp tag-pair) (identifier? (first tag-pair)) - (second tag-pair) (null (cddr tag-pair))) - (error "Bad oneof or tuple pair ~S" tag-pair)) - (let ((tag (first tag-pair))) - (when (member tag tags-so-far) - (error "Duplicate oneof or tuple tag ~S" tag)) - (scan-tuple-or-oneof - world - allow-forward-references - kind - (cdr tag-pairs) - (cons tag tags-so-far) - (cons (scan-type world (second tag-pair) allow-forward-references) types-so-far)))) - (make-type world kind (nreverse tags-so-far) (nreverse types-so-far)))) - -; (oneof ( ) ... ( )) -(defun scan-oneof (world allow-forward-references &rest tags-and-types) - (scan-tuple-or-oneof world allow-forward-references :oneof tags-and-types nil nil)) - -; (tuple ( ) ... ( )) -(defun scan-tuple (world allow-forward-references &rest tags-and-types) - (scan-tuple-or-oneof world allow-forward-references :tuple tags-and-types nil nil)) - - -; Scan tag to produce a tag that is present in the given tuple or oneof type. -; Return the tag and its field type. -(defun scan-tag (type tag) - (let ((field-type (field-type type tag))) - (unless field-type - (error "Tag ~S not present in ~A" tag (print-type-to-string type))) - (values tag field-type))) +; (union ... ) +(defun scan-union (world allow-forward-references &rest type-exprs) + (apply #'make-union-type world (mapcar #'(lambda (type-expr) + (scan-type world type-expr allow-forward-references)) + type-exprs))) ; Resolve all forward type references to refer to their target types. @@ -1175,7 +1637,6 @@ ; Return a list of all type structures encountered. (defun resolve-forward-types (world) (setf (world-types-reverse world) nil) - (setf (world-oneof-tags world) nil) (let ((visited-types (make-hash-table :test #'eq))) (labels ((resolve-in-type (type) @@ -1197,20 +1658,19 @@ (hash-table-keys visited-types))) -; Recompute the types-reverse and oneof-tags hash tables from the types in the types -; hash table and their constituents. +; Recompute the types-reverse hash table from the types in the types hash table and their constituents. (defun recompute-type-caches (world) (let ((types-reverse (make-hash-table :test #'equal))) - (setf (world-oneof-tags world) (make-hash-table :test #'equal)) (labels ((visit-type (type) - (let ((reverse-key (list (type-kind type) (type-tags type) (type-parameters type)))) + (let ((reverse-key (list (type-kind type) (type-tag type) (type-parameters type)))) (assert-true (eq (gethash reverse-key types-reverse type) type)) (unless (gethash reverse-key types-reverse) (setf (gethash reverse-key types-reverse) type) - (when (eq (type-kind type) :oneof) - (register-oneof-tags world type)) (mapc #'visit-type (type-parameters type)))))) + (visit-type (world-denormalized-false-type world)) + (visit-type (world-denormalized-true-type world)) + (visit-type (world-boxed-boolean-type world)) (each-type-definition world #'(lambda (symbol type) @@ -1224,13 +1684,15 @@ ; are affected, and names may be redirected to different type structures than ; the ones to which they currently point. It is the caller's responsibility ; to make sure that there are no current outstanding references to types other -; than via type names. +; than via type names (except for types for which it can be guaranteed that +; their type structures are defined only once; this applies to types such as +; integer and character but not (vector integer)). ; ; This function calls resolve-forward-types before making equivalent types be eq ; and recompute-type-caches just before returning. ; ; This function works by initially assuming that all types with the same kind -; and tags are the same type and then iterately determining which ones must be +; and tag are the same type and then iterately determining which ones must be ; different because they contain different parameter types. (defun unite-types (world) (let* ((types (resolve-forward-types world)) @@ -1267,8 +1729,7 @@ (let ((clique-representatives (make-array n-cliques :initial-element nil))) (maphash #'(lambda (type clique) (let ((representative (svref clique-representatives clique))) - (when (or (null representative) - (serial-number-< (type-name-serial-number type) (type-name-serial-number representative))) + (when (or (null representative) (type-named-serial-number-< type representative)) (setf (svref clique-representatives clique) type)))) types-to-cliques) (assert-true (every #'identity clique-representatives)) @@ -1286,10 +1747,117 @@ (multiple-value-call #'gen-cliques - (gen-cliques-1 #'(lambda (type) (cons (type-kind type) (type-tags type))))) + (gen-cliques-1 #'(lambda (type) (cons (type-kind type) (type-tag type))))) (recompute-type-caches world)))) +;;; ------------------------------------------------------------------------------------------------------ +;;; COMPARISONS + + +; 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) + (and (consp value1) (consp value2) + (let ((tag-name1 (car value1)) + (tag-name2 (car value2))) + (and (eq tag-name1 tag-name2) + (funcall (get tag-name1 :tag=) value1 value2)))))) + + +; Create an equality comparison function for elements of the given :vector type. +; Return the name of the function and also set it in the type. +(defun compute-vector-type-=-name (world type) + (let ((element-type (vector-element-type type))) + (case (type-kind element-type) + ((:integer :rational) (setf (type-=-name type) 'equal)) + (t (let ((=-name (gentemp (format nil "~A_VECTOR_=" (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)) + (every #',(get-type-=-name world element-type) a b)))) + =-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) + (let ((tag (type-tag type))) + (assert-true (null (tag-=-name tag))) + (labels + ((fields-=-code (fields) + (assert-true fields) + (let ((field-=-code (cons (get-type-=-name world (field-type (car fields))) '((car a) (car b))))) + (if (cdr fields) + `(and ,field-=-code + (let ((a (cdr a)) + (b (cdr b))) + ,(fields-=-code (cdr fields)))) + field-=-code)))) + + (let* ((name (tag-name tag)) + (=-name (world-intern world (concatenate 'string (string name) "_=")))) + (setf (type-=-name type) =-name) ;Must do this now to prevent runaway recursion. + (let ((=-code `(lambda (a b) + (let ((a (cdr a)) + (b (cdr b))) + ,(fields-=-code (tag-fields tag)))))) + (assert-true (not (fboundp =-name))) + (quiet-compile =-name =-code) + (setf (get name :tag=) (symbol-function =-name)) + (setf (tag-=-name tag) =-name)))))) + + +; Return the name of a function that compares two instances of this type and returns non-nil if they are equal. +; Signal an error if there is no such function. +; If the type is a tag, also set the :tag= property of the tag. +(defun get-type-=-name (world type) + (or (type-=-name type) + (case (type-kind type) + (:vector (compute-vector-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. + (dolist (subtype (type-parameters type)) + (get-type-=-name world subtype)) ;Set the :tag= symbol properties. + 'union=) + (t (error "Can't apply = to instances of type ~S" (print-type-to-string type)))))) + + +; Return the name of a function that compares two instances of this type and returns non-nil if they satisfy the given +; order, which should be one of the symbols =, /=, <, >, <=, >=. +; Signal an error if there is no such function except for /=, in which case return nil. +(defun get-type-order-name (world type order) + (ecase order + (= (get-type-=-name world type)) + (/= (type-/=-name type)) + ((< > <= >=) + (or (cdr (assoc order + (case (type-kind type) + ((:integer :rational) '((< . <) (> . >) (<= . <=) (>= . >=))) + (:character '((< . char<) (> . char>) (<= . char<=) (>= . char>=))) + (:string '((< . string<) (> . string>) (<= . string<=) (>= . string>=)))))) + (error "Can't apply ~A to instances of type ~A" order (print-type-to-string type)))))) + + +; Return code to compare code expression a against b using the given order, which should be one of +; the symbols =, /=, <, >, <=, >=.. +; Signal an error if this is not possible. +(defun get-type-order-code (world type order a b) + (flet ((simple-constant? (code) + (or (keywordp code) (numberp code) (characterp code)))) + (let ((order-name (get-type-order-name world type order))) + (cond + ((null order-name) + (assert-true (eq order '/=)) + (list 'not (get-type-order-code world type '= a b))) + ((and (eq order-name 'union=) (or (simple-constant? a) (simple-constant? b))) + ;Optimize union= comparisons against a non-list constant. + (list 'eql a b)) + (t (list order-name a b)))))) + + + ;;; ------------------------------------------------------------------------------------------------------ ;;; SPECIALS @@ -1301,28 +1869,33 @@ fun)) -; Add a macro, command, or special form definition. symbol is a symbol that names the -; preprocessor directive, macro, command, or special form. When a semantic form +; Add a command or special form definition. symbol is a symbol that names the +; preprocessor directive, command, or special form. When a semantic form ; (id arg1 arg2 ... argn) ; is encountered and id is a symbol with the same name as symbol, the form is ; replaced by the result of calling one of: ; (expander preprocessor-state id arg1 arg2 ... argn) if property is :preprocess -; (expander world type-env arg1 arg2 ... argn) if property is :macro ; (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 allow-forward-references arg1 arg2 ... argn) if property is :type-constructor ; expander must be a function or a function symbol. ; -; depictor is used instead of expander when emitting markup for the macro, command, or special form. +; In the case of the statement expander only, rest is a list of the remaining statements in the block; +; the statement expander should recursively expand the statements in rest. +; last is non-nil if this statement+rest's return value would pass through as the return value of the function; +; last allows optimization of lisp code to eliminate extraneous return-from statements. +; +; depictor is used instead of expander when emitting markup for the command or special form. ; depictor is called via: -; (depictor markup-stream world level arg1 arg2 ... argn) if property is :macro ; (depictor markup-stream world depict-env arg1 arg2 ... argn) if property is :command +; (depictor markup-stream world arg1 arg2 ... argn) if property is :statement ; (depictor markup-stream world level arg1 arg2 ... argn) if property is :special-form ; (depictor markup-stream world level arg1 arg2 ... argn) if property is :type-constructor ; (defun add-special (property symbol expander &optional depictor) - (let ((emit-property (cdr (assoc property '((:macro . :depict-macro) - (:command . :depict-command) + (let ((emit-property (cdr (assoc property '((:command . :depict-command) + (:statement . :depict-statement) (:special-form . :depict-special-form) (:type-constructor . :depict-type-constructor)))))) (assert-true (or emit-property (not depictor))) @@ -1379,13 +1952,13 @@ (setf (primitive-type primitive) (scan-type world (primitive-type-expr primitive)))) -; If name is an identifier not already used by a special form, command, primitive, or macro, +; If name is an identifier not already used by a special form, command, or primitive, ; return it interened into the world's package. If not, generate an error. (defun scan-name (world name) (unless (identifier? name) (error "~S should be an identifier" name)) (let ((symbol (world-intern world name))) - (when (get-properties (symbol-plist symbol) '(:command :special-form :primitive :macro :type-constructor)) + (when (get-properties (symbol-plist symbol) '(:command :statement :special-form :primitive :type-constructor)) (error "~A is reserved" symbol)) symbol)) @@ -1398,50 +1971,49 @@ ;;; shadows ones further in the list. ;;; The following kinds of bindings are allowed in a type environment: ;;; -;;; (symbol . type) -;;; Normal local variable, where: -;;; symbol is a world-interned name of the local variable; -;;; type is that variable's type. +;;; (see below) +;;; Normal local variable +;;; +;;; (see below) +;;; Action variable +;;; +;;; (:return . type) +;;; The function's return type +;;; +;;; (:return-block-name . symbol-or-nil) +;;; The name of the lisp return-from block to be used for returning from this function or nil if not needed yet. +;;; This binding's symbol-or-nil is mutated in place as needed. ;;; ;;; (:lhs-symbol . symbol) ;;; The lhs nonterminal's symbol if this is a type environment for an action function. ;;; -;;; ((action symbol . index) local-symbol type general-grammar-symbol) -;;; Action variable, where: -;;; action is a world-interned symbol denoting the action function being called -;;; symbol is a terminal or nonterminal's symbol on which the action is called -;;; index is the one-based index used to distinguish among identical -;;; symbols in the rhs of a production. The first occurrence of this -;;; symbol has index 1, the second has index 2, and so on. -;;; local-symbol is a unique local variable name used to represent the action -;;; function's value in the generated lisp code -;;; type is the type of the action function's value -;;; general-grammar-symbol is the general-grammar-symbol corresponding to the index-th -;;; instance of symbol in the production's rhs -;;; -;;; (:no-code-gen) -;;; If present, this indicates that the code returned from this scan-value or related call -;;; will be discarded; only the type is important. This flag is used as an optimization. + +(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 + +(defstruct (type-env-action (:type list) (:constructor make-type-env-action (key local-symbol type general-grammar-symbol))) + key ;(action symbol . index) + ; ; action is a world-interned symbol denoting the action function being called + ; ; symbol is a terminal or nonterminal's symbol on which the action is called + ; ; index is the one-based index used to distinguish among identical + ; ; symbols in the rhs of a production. The first occurrence of this + ; ; symbol has index 1, the second has index 2, and so on. + local-symbol ;A unique local variable name used to represent the action function's value in the generated lisp code + type ;Type of the action function's value + general-grammar-symbol) ;The general-grammar-symbol corresponding to the index-th instance of symbol in the production's rhs + (defconstant *null-type-env* nil) +(defconstant *type-env-flags* '(:return :return-block-name :lhs-symbol)) -; If symbol is a local variable, return two values: -; the name to use to refer to it from the generated lisp code; -; the variable's type. -; Otherwise, return nil. +; If symbol is a local variable, return its binding; if not, return nil. ; symbol must already be world-interned. -(declaim (inline type-env-local)) -(defun type-env-local (type-env symbol) - (let ((binding (assoc symbol type-env :test #'eq))) - (when binding - (values (car binding) (cdr binding))))) - - -; If the currently generated function is an action, return that action production's -; lhs nonterminal's symbol; otherwise return nil. -(defun type-env-lhs-symbol (type-env) - (cdr (assoc ':lhs-symbol type-env :test #'eq))) +(declaim (inline type-env-get-local)) +(defun type-env-get-local (type-env symbol) + (assoc symbol type-env :test #'eq)) ; If the currently generated function is an action for a rule with at least index @@ -1453,26 +2025,66 @@ ; the general-grammar-symbol corresponding to the index-th instance of this symbol in the rhs. ; Otherwise, return nil. ; action must already be world-interned. -(defun type-env-action (type-env action symbol index) - (let ((binding (assoc (list* action symbol index) type-env :test #'equal))) - (when binding - (values (second binding) (third binding) (fourth binding))))) +(defun type-env-get-action (type-env action symbol index) + (assoc (list* action symbol index) type-env :test #'equal)) -; Append bindings to the front of the type-env. The bindings list is destroyed. -(declaim (inline type-env-add-bindings)) -(defun type-env-add-bindings (type-env bindings) - (nconc bindings type-env)) +; Nondestructively append the binding to the front of the type-env and return the new type-env. +; If shadow is true, the binding may shadow an existing local variable with the same name. +(defun type-env-add-binding (type-env name type mode &optional shadow) + (assert-true (and + (symbolp name) + (type? type) + (member mode '(:const :var :function :unused)))) + (unless shadow + (let ((binding (type-env-get-local type-env name))) + (when binding + (error "Local variable ~A:~A shadows an existing local variable ~A:~A" + name (print-type-to-string type) + (type-env-local-name binding) (print-type-to-string (type-env-local-type binding)))))) + (cons (make-type-env-local name type mode) type-env)) -; Return an environment obtained from the type-env by adding a :no-code-gen binding. -(defun inhibit-code-gen (type-env) - (cons (list ':no-code-gen) type-env)) +; 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)))) + (type-env-add-binding type-env name type (type-env-local-mode binding) t))) -; Return true if the type-env indicates that its code will be discarded. -(defun code-gen-inhibited (type-env) - (assoc ':no-code-gen type-env)) +; Nondestructively shadow all writable bindings in the type-env by unused bindings and return the new type-env. +; Also create new bindings for the function's return type and return block name. +(defun type-env-init-function (type-env return-type) + (dolist (binding type-env) + (let ((name (first binding))) + (when (and (symbolp name) (not (keywordp name)) (eq (type-env-local-mode binding) :var)) + (let* ((first-binding (type-env-get-local type-env name)) + (first-mode (type-env-local-mode first-binding))) + (assert-true first-mode) + (unless (eq first-mode :unused) + (push (make-type-env-local (type-env-local-name first-binding) (type-env-local-type first-binding) :unused) type-env)))))) + (set-type-env-flag + (set-type-env-flag type-env :return return-type) + :return-block-name + nil)) + + +; Either reuse or generate a name for return-from statements exiting this function. +(defun gen-type-env-return-block-name (type-env) + (let ((return-block-binding (assert-non-null (assoc :return-block-name type-env)))) + (or (cdr return-block-binding) + (setf (cdr return-block-binding) (gensym "RETURN"))))) + + +; Return an environment obtained from the type-env by adding a binding of flag to value. +(defun set-type-env-flag (type-env flag value) + (assert-true (member flag *type-env-flags*)) + (acons flag value type-env)) + + +; Return the value bound to the given flag. +(defun get-type-env-flag (type-env flag) + (assert-true (member flag *type-env-flags*)) + (cdr (assoc flag type-env))) ;;; ------------------------------------------------------------------------------------------------------ @@ -1484,17 +2096,37 @@ ;;; An integer ;;; A rational number ;;; A double-precision floating-point number (or :+inf, :-inf, or :nan) -;;; An id (represented by a lisp symbol) ;;; A character ;;; 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 tuple (represented by a list of elements' values) -;;; A oneof (represented by a pair: tag . value) -;;; An address (represented by a cons cell whose cdr contains the value and car contains a serial number) +;;; 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. -(defvar *address-counter* 0) ;Last used address serial number +; Return true if the value appears to have the given tag. 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 test at the top level. +(defun value-has-tag (value tag &optional shallow) + (labels + ((check-fields (fields values) + (if (endp fields) + (null values) + (and (consp values) + (or shallow (value-has-type (car values) (field-type (car fields)))) + (check-fields (cdr fields) (cdr values)))))) + (let ((keyword (tag-keyword tag))) + (if keyword + (eq value keyword) + (and (consp value) + (eq (car value) (tag-name tag)) + (let ((values (cdr value)) + (fields (tag-fields tag))) + (if (tag-mutable tag) + (and (consp values) (integerp (car values)) (check-fields fields (cdr values))) + (check-fields fields values)))))))) ; Return true if the value appears to have the given type. This function @@ -1504,40 +2136,26 @@ (defun value-has-type (value type &optional shallow) (case (type-kind type) (:bottom nil) - (:void (null value)) + (:void t) (:boolean t) (:integer (integerp value)) (:rational (rationalp value)) - (:float64 (float64? value)) - (:id (and value (symbolp value))) + (:finite64 (and (floatp value) (not (zerop value)))) (:character (characterp value)) (:-> (functionp value)) + (:string (stringp value)) (:vector (let ((element-type (vector-element-type type))) - (if (eq (type-kind element-type) :character) - (stringp value) - (labels - ((test (value) - (or (null value) - (and (consp value) - (or shallow (value-has-type (car value) element-type)) - (test (cdr value)))))) - (test value))))) + (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)) - (:tuple (labels - ((test (value types) - (or (and (null value) (null types)) - (and (consp value) - (consp types) - (or shallow (value-has-type (car value) (car types))) - (test (cdr value) (cdr types)))))) - (test value (type-parameters type)))) - (:oneof (and (consp value) - (let ((field-type (field-type type (car value)))) - (and field-type - (or shallow (value-has-type (cdr value) field-type)))))) - (:address (and (consp value) - (integerp (car value)) - (or shallow (value-has-type (cdr value) (address-element-type type))))) + (: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))))) @@ -1548,21 +2166,16 @@ (:void (assert-true (null value)) (write-string "empty" stream)) (:boolean (write-string (if value "true" "false") stream)) - ((:integer :rational :id :character :->) (write value :stream stream)) - (:float64 (case value - (:+inf (write-string "+infinity" stream)) - (:-inf (write-string "-infinity" stream)) - (:nan (write-string "NaN" stream)) - (t (write value :stream stream)))) + ((:integer :rational :character :->) (write value :stream stream)) + (:finite64 (write value :stream stream)) + (:string (prin1 value stream)) (:vector (let ((element-type (vector-element-type type))) - (if (eq (type-kind element-type) :character) - (prin1 value stream) - (pprint-logical-block (stream value :prefix "(" :suffix ")") + (pprint-logical-block (stream value :prefix "(" :suffix ")") + (pprint-exit-if-list-exhausted) + (loop + (print-value (pprint-pop) element-type stream) (pprint-exit-if-list-exhausted) - (loop - (print-value (pprint-pop) element-type stream) - (pprint-exit-if-list-exhausted) - (format stream " ~:_")))))) + (format stream " ~:_"))))) (:set (let ((converter (set-out-converter (set-element-type type)))) (pprint-logical-block (stream value :prefix "{" :suffix "}") (pprint-exit-if-list-exhausted) @@ -1575,17 +2188,22 @@ (write (list (funcall converter value1) (funcall converter value2)) :stream stream)))) (pprint-exit-if-list-exhausted) (format stream " ~:_")))) - (:tuple (print-values value (type-parameters type) stream :prefix "[" :suffix "]")) - (:oneof (pprint-logical-block (stream nil :prefix "{" :suffix "}") - (let* ((tag (car value)) - (field-type (field-type type tag))) - (format stream "~A" tag) - (unless (eq (type-kind field-type) :void) + (:tag (let ((tag (type-tag type))) + (if (tag-keyword tag) + (write value :stream stream) + (pprint-logical-block (stream (tag-fields tag) :prefix "[" :suffix "]") + (write (pop value) :stream stream) + (when (tag-mutable tag) + (format stream " ~:_~D" (pop value))) + (loop + (pprint-exit-if-list-exhausted) (format stream " ~:_") - (print-value (cdr value) field-type stream))))) - (:address (pprint-logical-block (stream nil :prefix "{" :suffix "}") - (format stream "~D ~:_" (car value)) - (print-value (cdr value) (address-element-type type) stream))) + (print-value (pop value) (field-type (pprint-pop)) stream)))))) + (:union (dolist (subtype (type-parameters type) + (error "~S is not an instance of ~A" value (print-type-to-string type))) + (when (value-has-type value subtype t) + (print-value value subtype stream) + (return)))) (t (error "Bad typekind ~S" (type-kind type))))) @@ -1615,29 +2233,29 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage "EXPR-ANNOTATION" (:use) - (:export "CONSTANT" ;(expr-annotation:constant ) - "PRIMITIVE" ;(expr-annotation:primitive ) - "LOCAL" ;(expr-annotation:local ) ;Local or lexically scoped variable - "GLOBAL" ;(expr-annotation:global ) ;Global variable - "CALL" ;(expr-annotation:call ... ) - "ACTION" ;(expr-annotation:action ) - "SPECIAL-FORM" ;(expr-annotation:special-form ...) - "MACRO"))) ;(expr-annotation:macro ) + (:export "CONSTANT" ;(expr-annotation:constant ) + "PRIMITIVE" ;(expr-annotation:primitive ) + "TAG" ;(expr-annotation:tag ) + "LOCAL" ;(expr-annotation:local ) ;Local or lexically scoped variable + "GLOBAL" ;(expr-annotation:global ) ;Global variable + "CALL" ;(expr-annotation:call ... ) + "ACTION" ;(expr-annotation:action ) + "BEGIN" ;(expr-annotation:begin ... ) + "SPECIAL-FORM"))) ;(expr-annotation:special-form ...) + + +; Return true if the annotated-stmt is a statement with the given special-form, which must be a symbol +; but does not have to be interned in the world's package. +(defun special-form-annotated-stmt? (world special-form annotated-stmt) + (eq (first annotated-stmt) (world-find-symbol world special-form))) ; Return true if the annotated-expr is a special form annotated expression with ; the given special-form. special-form must be a symbol but does not have to be interned ; in the world's package. -(defun special-form-annotated-expr? (special-form annotated-expr) +(defun special-form-annotated-expr? (world special-form annotated-expr) (and (eq (first annotated-expr) 'expr-annotation:special-form) - (string= (symbol-name (second annotated-expr)) (symbol-name special-form)))) - - -; Return true if the annotated-expr is a macro annotated expression with the given macro. -; macro must be a symbol but does not have to be interned in the world's package. -(defun macro-annotated-expr? (macro annotated-expr) - (and (eq (first annotated-expr) 'expr-annotation:macro) - (string= (symbol-name (second annotated-expr)) (symbol-name macro)))) + (eq (second annotated-expr) (world-find-symbol world special-form)))) ; Return the value of the variable with the given symbol. @@ -1675,69 +2293,86 @@ (let ((arg-values (nreverse arg-values)) (arg-types (nreverse arg-types)) (arg-annotated-exprs (nreverse arg-annotated-exprs))) - (unless (and (eq (type-kind function-type) :->) - (= (length arg-types) (length (->-argument-types function-type))) - (every #'type<= arg-types (->-argument-types function-type))) - (error "~@" - value-expr - (print-type-to-string function-type) - (mapcar #'print-type-to-string arg-types))) - (values (apply #'gen-apply function-value arg-values) - (->-result-type function-type) - (list* 'expr-annotation:call function-annotated-expr arg-annotated-exprs))))) + (handler-bind (((or error warning) + #'(lambda (condition) + (declare (ignore condition)) + (format *error-output* + "~@" + value-expr + (print-type-to-string function-type) + (mapcar #'print-type-to-string arg-types))))) + (unless (eq (type-kind function-type) :->) + (error "Non-function called")) + (let ((parameter-types (->-argument-types function-type))) + (unless (= (length arg-types) (length parameter-types)) + (error "Argument count mismatch")) + (let ((arg-values (mapcar #'(lambda (arg-expr arg-value arg-type parameter-type) + (widening-coercion-code world parameter-type arg-type arg-value arg-expr)) + arg-exprs arg-values arg-types parameter-types))) + (values (apply #'gen-apply function-value arg-values) + (->-result-type function-type) + (list* 'expr-annotation:call function-annotated-expr arg-annotated-exprs)))))))) ;Scan an action call (scan-action-call (action symbol &optional (index 1 index-supplied)) (unless (integerp index) (error "Production rhs grammar symbol index ~S must be an integer" index)) - (multiple-value-bind (symbol-code symbol-type general-grammar-symbol) (type-env-action type-env action symbol index) - (unless symbol-code + (let ((symbol-action (type-env-get-action type-env action symbol index))) + (unless symbol-action (error "Action ~S not found" (list action symbol index))) - (let ((multiple-symbols (type-env-action type-env action symbol 2))) + (let ((multiple-symbols (type-env-get-action type-env action symbol 2))) (when (and (not index-supplied) multiple-symbols) (error "Ambiguous index in action ~S" (list action symbol))) - (values symbol-code - symbol-type - (list* 'expr-annotation:action action general-grammar-symbol + (values (type-env-action-local-symbol symbol-action) + (type-env-action-type symbol-action) + (list* 'expr-annotation:action action (type-env-action-general-grammar-symbol symbol-action) (and (or multiple-symbols - (grammar-symbol-= symbol (assert-non-null (type-env-lhs-symbol type-env)))) + (grammar-symbol-= symbol (assert-non-null (get-type-env-flag type-env :lhs-symbol)))) (list index))))))) ;Scan an interned identifier (scan-identifier (symbol) - (multiple-value-bind (symbol-code symbol-type) (type-env-local type-env symbol) - (if symbol-code - (values symbol-code symbol-type (list 'expr-annotation:local symbol)) + (let ((symbol-binding (type-env-get-local type-env symbol))) + (if symbol-binding + (ecase (type-env-local-mode symbol-binding) + ((:const :var) + (values (type-env-local-name symbol-binding) + (type-env-local-type symbol-binding) + (list 'expr-annotation:local symbol))) + (:function + (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))) (let ((primitive (symbol-primitive symbol))) (if primitive (values (primitive-value-code primitive) (primitive-type primitive) (list 'expr-annotation:primitive symbol)) - (let ((type (symbol-type symbol))) - (if type - (values (if (eq (type-kind type) :->) - (list 'symbol-function (list 'quote symbol)) - (list 'fetch-value symbol)) - type - (list 'expr-annotation:global symbol)) - (syntax-error)))))))) + (let ((tag (symbol-tag symbol))) + (if (and tag (tag-keyword tag)) + (values (tag-keyword tag) + (make-tag-type world tag) + (list 'expr-annotation:tag tag)) + (let ((type (symbol-type symbol))) + (if type + (values (if (eq (type-kind type) :->) + (list 'symbol-function (list 'quote symbol)) + (list 'fetch-value symbol)) + type + (list 'expr-annotation:global symbol)) + (syntax-error)))))))))) - ;Scan a call or macro expansion + ;Scan a call or special form (scan-cons (first rest) (if (identifier? first) - (let* ((symbol (world-intern world first)) - (expander (symbol-macro symbol))) - (if expander - (multiple-value-bind (expansion-code expansion-type expansion-annotated-expr) - (scan-value world type-env (apply expander world type-env rest)) - (values - expansion-code - expansion-type - (list 'expr-annotation:macro symbol expansion-annotated-expr))) - (let ((handler (get symbol :special-form))) - (if handler - (apply handler world type-env symbol rest) - (if (and (symbol-action symbol) (not (type-env-local type-env symbol))) - (apply #'scan-action-call symbol rest) - (multiple-value-call #'scan-call (scan-identifier symbol) rest)))))) + (let ((symbol (world-intern world first))) + (let ((handler (get symbol :special-form))) + (if handler + (apply handler world type-env symbol rest) + (if (and (symbol-action symbol) + (let ((local (type-env-get-local type-env symbol))) + (not (and local (eq (type-kind (type-env-local-type local)) :->))))) + (apply #'scan-action-call symbol rest) + (multiple-value-call #'scan-call (scan-identifier symbol) rest))))) (multiple-value-call #'scan-call (scan-value world type-env first) rest))) (scan-constant (value-expr type) @@ -1748,87 +2383,98 @@ ((consp value-expr) (scan-cons (first value-expr) (rest value-expr))) ((identifier? value-expr) (scan-identifier (world-intern world value-expr))) ((integerp value-expr) (scan-constant value-expr (world-integer-type world))) - ((floatp value-expr) (scan-constant value-expr (world-float64-type world))) + ((floatp value-expr) + (if (zerop value-expr) + (error "Use +zero or -zero instead of 0.0") + (scan-constant value-expr (world-finite64-type world)))) ((characterp value-expr) (scan-constant value-expr (world-character-type world))) ((stringp value-expr) (scan-constant value-expr (world-string-type world))) (t (syntax-error)))))) -; Same as scan-value except that return only the expression's type. -(defun scan-value-type (world type-env value-expr) - (nth-value 1 (scan-value world (inhibit-code-gen type-env) value-expr))) - - ; Same as scan-value except that ensure that the value has the expected type. ; Return two values: ; The expression's value (a lisp expression) ; The annotated value-expr (defun scan-typed-value (world type-env value-expr expected-type) (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) - (unless (type<= type expected-type) - (error "Expected type ~A for ~:W but got type ~A" - (print-type-to-string expected-type) - value-expr - (print-type-to-string type))) - (values value annotated-expr))) + (values (widening-coercion-code world expected-type type value value-expr) annotated-expr))) -; Same as scan-value except that ensure that the value has the expected type kind. +; Same as scan-value except that ensure that the value has type bottom or void. +; Return three values: +; The expression's value (a lisp expression) +; True if value has type void +; The annotated value-expr +(defun scan-void-value (world type-env value-expr) + (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) + (values + value + (case (type-kind type) + (:bottom nil) + (:void t) + (t (error "Value ~S:~A should be void" value-expr (print-type-to-string type)))) + annotated-expr))) + + +; Same as scan-value except that ensure that the value is a vector type. ; Return three values: ; The expression's value (a lisp expression) ; The expression's type ; The annotated value-expr -(defun scan-kinded-value (world type-env value-expr expected-type-kind) +(defun scan-vector-value (world type-env value-expr) (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) - (unless (typekind<= (type-kind type) expected-type-kind) - (error "Expected ~(~A~) for ~:W but got type ~A" - expected-type-kind - value-expr - (print-type-to-string type))) + (unless (member (type-kind type) '(:string :vector)) + (error "Value ~S:~A should be a vector" value-expr (print-type-to-string type))) + (values value type annotated-expr))) + + +; Same as scan-value except that ensure that the value is a tag 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) + (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))) (values value type annotated-expr))) ; 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) - (multiple-value-bind (value-code value-type) (scan-value (symbol-world symbol) *null-type-env* value-expr) - (unless (type<= value-type type) - (error "~A evaluates to type ~A, but is defined with type ~A" - symbol - (print-type-to-string value-type) - (print-type-to-string type))) - value-code)) + (scan-typed-value (symbol-world symbol) *null-type-env* value-expr type)) + + +; Same as scan-typed-value except that also allow the form (begin . ); in this case +; return can be used to return the expression's value. +; Return two values: +; The expression's value (a lisp expression) +; The annotated value-expr +(defun scan-typed-value-or-begin (world type-env value-expr expected-type) + (if (and (consp value-expr) (eq (first value-expr) 'begin)) + (let* ((result-type (scan-type world expected-type)) + (local-type-env (type-env-init-function type-env result-type))) + (multiple-value-bind (body-codes body-annotated-stmts) (finish-function-code world local-type-env result-type (cdr value-expr)) + (values (gen-progn body-codes) + (cons 'expr-annotation:begin body-annotated-stmts)))) + (scan-typed-value world type-env value-expr expected-type))) + -#| -(defun compute-variable-function (symbol value-expr type) - (handler-bind (((or error warning) - #'(lambda (condition) - (declare (ignore condition)) - (format *error-output* "~&~@<~2IWhile computing ~A: ~_~:W~:>~%" - symbol value-expr)))) - (assert-true (not (or (boundp symbol) (fboundp symbol)))) - (let ((code (gen-defun (scan-global-value symbol value-expr type) symbol (length (->-argument-types type))))) - (when *trace-variables* - (format *trace-output* "~&~S ::= ~:W~%" symbol code)) - (setf (symbol-code symbol) code) - code))) -|# ; Generate the defun code for the world's variable named by symbol. ; The variable's type must be ->. (defun compute-variable-function (symbol value-expr type) (handler-bind (((or error warning) #'(lambda (condition) (declare (ignore condition)) - (format *error-output* "~&~@<~2IWhile computing ~A: ~_~:W~:>~%" - symbol value-expr)))) + (format *error-output* "~&~@<~2IWhile computing ~A: ~_~:W~:>~%" symbol value-expr)))) (assert-true (not (or (boundp symbol) (fboundp symbol)))) (let ((code (strip-function (scan-global-value symbol value-expr type) symbol (length (->-argument-types type))))) (when *trace-variables* (format *trace-output* "~&~S ::= ~:W~%" symbol code)) - (setf (symbol-code symbol) code) - (let (#+mcl (ccl::*suppress-compiler-warnings* t)) - (compile symbol code))))) + (quiet-compile symbol code)))) (defvar *busy-variables* nil) @@ -1852,84 +2498,10 @@ (format *error-output* "~&~@<~2IWhile computing ~A: ~_~:W~:>~%" symbol value-expr)))) (assert-true (not (eq (type-kind type) :->))) - (let ((named-value-code (name-lambda (scan-global-value symbol value-expr type) symbol))) - (setf (symbol-code symbol) named-value-code) + (let ((value-code (scan-global-value symbol value-expr type))) (when *trace-variables* - (format *trace-output* "~&~S := ~:W~%" symbol named-value-code)) - (set symbol (eval named-value-code)))))))) - - -; Compute the initial type-env to use for the given general-production's action code. -; The first cell of the type-env gives the production's lhs nonterminal's symbol; -; the remaining cells give the action arguments in order. -(defun general-production-action-env (grammar general-production) - (let* ((current-indices nil) - (lhs-general-nonterminal (general-production-lhs general-production)) - (bound-arguments-alist (nonterminal-sample-bound-argument-alist grammar lhs-general-nonterminal))) - (acons ':lhs-symbol (general-grammar-symbol-symbol lhs-general-nonterminal) - (mapcan - #'(lambda (general-grammar-symbol) - (let* ((symbol (general-grammar-symbol-symbol general-grammar-symbol)) - (index (incf (getf current-indices symbol 0))) - (grammar-symbol (instantiate-general-grammar-symbol bound-arguments-alist general-grammar-symbol))) - (mapcar - #'(lambda (declaration) - (let* ((action-symbol (car declaration)) - (action-type (cdr declaration)) - (local-symbol (gensym (symbol-name action-symbol)))) - (list - (list* action-symbol symbol index) - local-symbol - action-type - general-grammar-symbol))) - (grammar-symbol-signature grammar grammar-symbol)))) - (general-production-rhs general-production))))) - - -; Return the number of arguments that a function returned by compute-action-code -; would expect. -(defun n-action-args (grammar production) - (let ((n-args 0)) - (dolist (grammar-symbol (production-rhs production)) - (incf n-args (length (grammar-symbol-signature grammar grammar-symbol)))) - n-args)) - - -; Compute the code for evaluating body-expr to obtain the value of one of the -; production's actions. Verify that the result has the given type. -; The code is a lambda-expression that takes as arguments the results of all -; defined actions on the production's rhs. The arguments are listed in the -; same order as the grammar symbols in the rhs. If a grammar symbol in the rhs -; has more than one associated action, arguments are used corresponding to all -; of the actions in the same order as they were declared. If a grammar symbol -; in the rhs has no associated actions, no argument is used for it. -(defun compute-action-code (world grammar production action-symbol body-expr type) - (handler-bind ((error #'(lambda (condition) - (declare (ignore condition)) - (format *error-output* "~&~@<~2IWhile processing action ~A on ~S: ~_~:W~:>~%" - action-symbol (production-name production) body-expr)))) - (let* ((initial-env (general-production-action-env grammar production)) - (args (mapcar #'cadr (cdr initial-env))) - (body-code (scan-typed-value world initial-env body-expr type)) - (named-body-code (name-lambda body-code - (concatenate 'string (symbol-name (production-name production)) - "~" (symbol-name action-symbol)) - (world-package world)))) - (gen-lambda args named-body-code)))) - - -; Return a list of all grammar symbols's symbols that are present in at least one expr-annotation:action -; in the annotated expression. The symbols are returned in no particular order. -(defun annotated-expr-grammar-symbols (annotated-expr) - (let ((symbols nil)) - (labels - ((scan (annotated-expr) - (when (consp annotated-expr) - (if (eq (first annotated-expr) 'expr-annotation:action) - (pushnew (general-grammar-symbol-symbol (third annotated-expr)) symbols :test *grammar-symbol-=*) - (mapc #'scan annotated-expr))))) - (scan annotated-expr) - symbols))) + (format *trace-output* "~&~S := ~:W~%" symbol value-code)) + (set symbol (eval value-code)))))))) ;;; ------------------------------------------------------------------------------------------------------ @@ -1938,9 +2510,10 @@ ;;; Constants (defun eval-bottom () - (error "Reached a BOTTOM statement")) + (error "Reached a BOTTOM expression")) ; (bottom) +; (todo) ; Raises an error. (defun scan-bottom (world type-env special-form) (declare (ignore type-env)) @@ -1950,20 +2523,6 @@ (list 'expr-annotation:special-form special-form))) -; (^ ) -; Alternative way of writing the integer or rational constant ^. -(defun scan-^ (world type-env special-form base exponent) - (declare (ignore type-env)) - (unless (and (integerp base) (integerp exponent) (plusp base)) - (error "Bad constant ~S^~S" base exponent)) - (values - (expt base exponent) - (if (minusp exponent) - (world-rational-type world) - (world-integer-type world)) - (list 'expr-annotation:special-form special-form base exponent))) - - ; (hex []) ; Alternative way of writing the integer in hexadecimal. length is the minimum number of digits to write. (defun scan-hex (world type-env special-form n &optional (length 1)) @@ -1976,110 +2535,226 @@ (list 'expr-annotation:special-form special-form n length))) -;;; Control structures +;;; Expressions -; (function (( [:unused]) ... ( [:unused])) ) -(defun scan-function (world type-env special-form arg-binding-exprs body-expr) - (flet - ((scan-arg-binding (arg-binding-expr) - (unless (and (consp arg-binding-expr) - (consp (cdr arg-binding-expr)) - (member (cddr arg-binding-expr) '(nil (:unused)) :test #'equal)) - (error "Bad function binding ~S" arg-binding-expr)) - (let ((arg-symbol (scan-name world (first arg-binding-expr))) - (arg-type (scan-type world (second arg-binding-expr)))) - (cons arg-symbol arg-type)))) - - (unless (listp arg-binding-exprs) - (error "Bad function bindings ~S" arg-binding-exprs)) - (let* ((arg-bindings (mapcar #'scan-arg-binding arg-binding-exprs)) - (args (mapcar #'car arg-bindings)) - (arg-types (mapcar #'cdr arg-bindings)) - (unused-args (mapcan #'(lambda (arg arg-binding-expr) - (when (eq (third arg-binding-expr) ':unused) - (list arg))) - args arg-binding-exprs)) - (type-env (type-env-add-bindings type-env arg-bindings))) - (multiple-value-bind (body-code body-type body-annotated-expr) (scan-value world type-env body-expr) - (values (if unused-args - `#'(lambda ,args (declare (ignore . ,unused-args)) ,body-code) - `#'(lambda ,args ,body-code)) - (make-->-type world arg-types body-type) - (list 'expr-annotation:special-form special-form arg-binding-exprs body-annotated-expr)))))) + +(defun semantic-expt (base exponent) + (assert-true (and (rationalp base) (integerp exponent))) + (when (and (zerop base) (not (plusp exponent))) + (error "0 raised to a nonpositive exponent")) + (expt base exponent)) + + +; (expt ) +; The result is rational unless both base and exponent are integer constants and the result is an integer. +(defun scan-expt (world type-env special-form base-expr exponent-expr) + (multiple-value-bind (base-code base-annotated-expr) (scan-typed-value world type-env base-expr (world-rational-type world)) + (multiple-value-bind (exponent-code exponent-annotated-expr) (scan-typed-value world type-env exponent-expr (world-integer-type world)) + (let ((code (list 'semantic-expt base-code exponent-code)) + (type (world-rational-type world))) + (when (and (constantp base-code) (constantp exponent-code)) + (setq code (semantic-expt base-code exponent-code)) + (when (integerp code) + (setq type (world-integer-type world)))) + (values + code + type + (list 'expr-annotation:special-form special-form base-annotated-expr exponent-annotated-expr)))))) + + +; Return the depict name for one of the comparison symbols =, /=, <, >, <=, >=. +(defun comparison-name (order) + (cdr (assoc order '((= . "=") (/= . :not-equal) (< . "<") (> . ">") (<= . :less-or-equal) (>= . :greater-or-equal))))) + + +; Both expr1 and expr2 are coerced to the given type and then compared using the given order. +; The result is a boolean. order-name should be suitable for depict. +(defun scan-comparison (world type-env special-form order expr1 expr2 type-expr) + (let ((type (scan-type world type-expr))) + (multiple-value-bind (code1 annotated-expr1) (scan-typed-value world type-env expr1 type) + (multiple-value-bind (code2 annotated-expr2) (scan-typed-value world type-env expr2 type) + (values + (get-type-order-code world type order code1 code2) + (world-boolean-type world) + (list 'expr-annotation:special-form special-form (comparison-name order) annotated-expr1 annotated-expr2)))))) + + +; (= []) +(defun scan-= (world type-env special-form expr1 expr2 &optional (type-expr 'integer)) + (scan-comparison world type-env special-form '= expr1 expr2 type-expr)) + +; (/= []) +(defun scan-/= (world type-env special-form expr1 expr2 &optional (type-expr 'integer)) + (scan-comparison world type-env special-form '/= expr1 expr2 type-expr)) + +; (< []) +(defun scan-< (world type-env special-form expr1 expr2 &optional (type-expr 'integer)) + (scan-comparison world type-env special-form '< expr1 expr2 type-expr)) + +; (> []) +(defun scan-> (world type-env special-form expr1 expr2 &optional (type-expr 'integer)) + (scan-comparison world type-env special-form '> expr1 expr2 type-expr)) + +; (<= []) +(defun scan-<= (world type-env special-form expr1 expr2 &optional (type-expr 'integer)) + (scan-comparison world type-env special-form '<= expr1 expr2 type-expr)) + +; (>= []) +(defun scan->= (world type-env special-form expr1 expr2 &optional (type-expr 'integer)) + (scan-comparison world type-env special-form '>= expr1 expr2 type-expr)) + + +; (cascade ... ) +; Shorthand for (and ( ) ( ) ... ( )), +; where each order must be one of the symbols =, /=, <, >, <=, >=. +; The intermediate expressions are evaluated at most once. +(defun scan-cascade (world type-env special-form type-expr expr1 &rest orders-and-exprs) + (let ((type (scan-type world type-expr))) + (labels + ((cascade (v1 orders-and-exprs) + (unless (and (consp orders-and-exprs) (consp (cdr orders-and-exprs)) + (member (first orders-and-exprs) '(= /= < > <= >=))) + (error "Bad cascade tail: ~S" orders-and-exprs)) + (let* ((order (first orders-and-exprs)) + (order-name (comparison-name order)) + (expr2 (second orders-and-exprs)) + (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"))) + (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)) + (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"))) + (multiple-value-bind (codes annotations) (cascade v1 orders-and-exprs) + (values + `(let ((,v1 ,code1)) ,codes) + (world-boolean-type world) + (list* 'expr-annotation:special-form special-form annotated-expr1 annotations)))))))) + + +; (and ... ) +; Short-circuiting logical AND. +(defun scan-and (world type-env special-form expr &rest exprs) + (apply #'scan-and-or-xor world type-env special-form 'and t expr exprs)) + +; (or ... ) +; Short-circuiting logical OR. +(defun scan-or (world type-env special-form expr &rest exprs) + (apply #'scan-and-or-xor world type-env special-form 'or nil expr exprs)) + +; (xor ... ) +; Logical XOR. +(defun scan-xor (world type-env special-form expr &rest exprs) + (apply #'scan-and-or-xor world type-env special-form 'xor nil expr exprs)) + +(defun scan-and-or-xor (world type-env special-form op identity &rest exprs) + (multiple-value-map-bind (codes annotated-exprs) + #'(lambda (expr) + (scan-typed-value world type-env expr (world-boolean-type world))) + (exprs) + (values + (gen-poly-op op identity codes) + (world-boolean-type world) + (list* 'expr-annotation:special-form special-form op annotated-exprs)))) + + +; (begin . ) +; Only allowed at the top level of an action. + + +(defun finish-function-code (world type-env result-type body-statements) + (multiple-value-bind (body-codes body-live body-annotated-stmts) (scan-statements world type-env body-statements t t) + (when (and body-live (not (or (type= result-type (world-void-type world)) + (type= result-type (world-bottom-type world))))) + (error "Execution falls off the end of a function with result type ~A" (print-type-to-string result-type))) + (let ((return-block-name (get-type-env-flag type-env :return-block-name))) + (values + (if return-block-name + (list (list* 'block return-block-name body-codes)) + body-codes) + body-annotated-stmts)))) + + +; Scan a local function. +; arg-binding-exprs should have the form (( [:unused]) ... ( [:unused])). +; result-type-expr should be a type expression. +; body-statements contains the function's body statements. +; Return three values: +; A list of lisp function bindings followed by the code (i.e. '((a b c) (declare (ignore c)) (* a b))); +; The function's complete type; +; The annotated body statements. +(defun scan-function-or-lambda (world type-env arg-binding-exprs result-type-expr body-statements) + (handler-bind (((or error warning) + #'(lambda (condition) + (declare (ignore condition)) + (format *error-output* "~&~@<~2IWhile processing lambda ~_~S ~_~S ~_~S:~:>~%" + arg-binding-exprs result-type-expr body-statements)))) + (let* ((result-type (scan-type world result-type-expr)) + (local-type-env (type-env-init-function type-env result-type)) + (args nil) + (arg-types nil) + (unused-args nil)) + (unless (listp arg-binding-exprs) + (error "Bad function bindings ~S" arg-binding-exprs)) + (dolist (arg-binding-expr arg-binding-exprs) + (unless (and (consp arg-binding-expr) + (consp (cdr arg-binding-expr)) + (member (cddr arg-binding-expr) '(nil (:unused)) :test #'equal)) + (error "Bad function binding ~S" arg-binding-expr)) + (let ((arg-symbol (scan-name world (first arg-binding-expr))) + (arg-type (scan-type world (second arg-binding-expr))) + (arg-mode (or (third arg-binding-expr) :const))) + (setq local-type-env (type-env-add-binding local-type-env arg-symbol arg-type arg-mode)) + (push arg-symbol args) + (push arg-type arg-types) + (when (eq arg-mode :unused) + (push arg-symbol unused-args)))) + (setq args (nreverse args)) + (setq arg-types (nreverse arg-types)) + (setq unused-args (nreverse unused-args)) + (multiple-value-bind (body-codes body-annotated-stmts) (finish-function-code world local-type-env result-type body-statements) + (when unused-args + (push (list 'declare (cons 'ignore unused-args)) body-codes)) + (values (cons args body-codes) + (make-->-type world arg-types result-type) + body-annotated-stmts))))) + + +; (lambda (( [:unused]) ... ( [:unused])) . ) +(defun scan-lambda (world type-env special-form arg-binding-exprs result-type-expr &rest body-statements) + (multiple-value-bind (args-and-body-codes type body-annotated-stmts) + (scan-function-or-lambda world type-env arg-binding-exprs result-type-expr body-statements) + (values + (list 'function (cons 'lambda args-and-body-codes)) + type + (list* 'expr-annotation:special-form special-form arg-binding-exprs result-type-expr body-annotated-stmts)))) ; (if ) -(defun scan-if (world type-env special-form condition-expr true-expr false-expr) +(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) - (let ((join-type (type-lub true-type false-type))) - (unless join-type - (error "~S: ~A and ~S: ~A used as alternatives in an if" - true-expr (print-type-to-string true-type) - false-expr (print-type-to-string false-type))) - (values - (list 'if condition-code true-code false-code) - join-type - (list 'expr-annotation:special-form special-form condition-annotated-expr true-annotated-expr false-annotated-expr))))))) - - -; (progn ... ) -(defun scan-progn (world type-env special-form expr1 expr2 &rest more-exprs) - (let* ((exprs (list* expr1 expr2 more-exprs)) - (last-expr (car (last exprs))) - (void-exprs (butlast exprs)) - (codes nil) - (annotated-exprs nil)) - (dolist (void-expr void-exprs) - (multiple-value-bind (void-code void-annotated-expr) - (scan-typed-value world type-env void-expr (world-void-type world)) - (push void-code codes) - (push void-annotated-expr annotated-exprs))) - (multiple-value-bind (last-code last-type last-annotated-expr) (scan-value world type-env last-expr) - (values - (cons 'progn (nreconc codes (list last-code))) - last-type - (list* 'expr-annotation:special-form special-form (nreconc annotated-exprs (list last-annotated-expr))))))) - - -(defconstant *semantic-exception-type-name* 'semantic-exception) - -; (throw ) -; must have type *semantic-exception-type-name*, which must be the name of some user-defined type in the environment. -(defun scan-throw (world type-env special-form value-expr) - (multiple-value-bind (value-code value-annotated-expr) - (scan-typed-value world type-env value-expr (scan-type world *semantic-exception-type-name*)) - (values - (list 'throw ':semantic-exception value-code) - (world-bottom-type world) - (list 'expr-annotation:special-form special-form value-annotated-expr)))) - - -; (catch ( [:unused]) ) -(defun scan-catch (world type-env special-form body-expr arg-binding-expr handler-expr) - (multiple-value-bind (body-code body-type body-annotated-expr) (scan-value world type-env body-expr) - (unless (and (consp arg-binding-expr) - (member (cdr arg-binding-expr) '(nil (:unused)) :test #'equal)) - (error "Bad catch binding ~S" arg-binding-expr)) - (let* ((arg-symbol (scan-name world (first arg-binding-expr))) - (arg-type (scan-type world *semantic-exception-type-name*)) - (arg-bindings (list (cons arg-symbol arg-type))) - (type-env (type-env-add-bindings type-env arg-bindings))) - (multiple-value-bind (handler-code handler-type handler-annotated-expr) (scan-value world type-env handler-expr) - (let ((join-type (type-lub body-type handler-type))) - (unless join-type - (error "~S: ~A and ~S: ~A used as alternatives in a catch" - body-expr (print-type-to-string body-type) - handler-expr (print-type-to-string handler-type))) - (values - `(block nil - (let ((,arg-symbol (catch ':semantic-exception (return ,body-code)))) - ,@(and (eq (second arg-binding-expr) ':unused) `((declare (ignore ,arg-symbol)))) - ,handler-code)) - join-type - (list 'expr-annotation:special-form special-form body-annotated-expr arg-binding-expr handler-annotated-expr))))))) + (handler-bind (((or error warning) + #'(lambda (condition) + (declare (ignore condition)) + (format *error-output* "~&~@<~2IWhile processing if with alternatives~_ ~S: ~A and~_ ~S: ~A:~:>~%" + true-expr (print-type-to-string true-type) + 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) + type + (list 'expr-annotation:special-form special-form condition-annotated-expr true-annotated-expr false-annotated-expr)))))))) ;;; Vectors @@ -2087,36 +2762,41 @@ (defmacro non-empty-vector (v operation-name) `(or ,v (error ,(concatenate 'string operation-name " called on empty vector")))) -; (vector ... ) +(defun make-vector-expr (world special-form element-type element-codes element-annotated-exprs) + (values + (if element-codes + (let ((elements-code (cons 'list element-codes))) + (if (eq element-type (world-character-type world)) + (if (cdr element-codes) + (list 'coerce elements-code ''string) + (list 'string (car element-codes))) + elements-code)) + (if (eq element-type (world-character-type world)) + "" + nil)) + (make-vector-type world element-type) + (list* 'expr-annotation:special-form special-form element-annotated-exprs))) + +; (vector ... ) ; Makes a vector of one or more elements. -(defun scan-vector-form (world type-env special-form element-expr &rest element-exprs) +(defun scan-vector-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) - (let ((elements-code (list* 'list element-code rest-codes))) - (values - (if (eq element-type (world-character-type world)) - (if element-exprs - (list 'coerce elements-code ''string) - (list 'string element-code)) - elements-code) - (make-vector-type world element-type) - (list* 'expr-annotation:special-form special-form element-annotated-expr rest-annotated-exprs)))))) + (make-vector-expr world special-form element-type (cons element-code rest-codes) (cons element-annotated-expr rest-annotated-exprs))))) -; (vector-of ) -; Makes a zero-element vector of elements of the given type. -(defun scan-vector-of (world type-env special-form element-type-expr) - (declare (ignore type-env)) +; (vector-of ... ) +; Makes a vector of zero or more elements of the given type. +(defun scan-vector-of (world type-env special-form element-type-expr &rest element-exprs) (let ((element-type (scan-type world element-type-expr))) - (values - (if (eq element-type (world-character-type world)) - "" - nil) - (make-vector-type world element-type) - (list 'expr-annotation:special-form special-form 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-vector-expr world special-form element-type element-codes element-annotated-exprs)))) ; (empty ) @@ -2124,7 +2804,7 @@ ; 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-kinded-value world type-env vector-expr :vector) + (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) @@ -2136,7 +2816,7 @@ ; (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-kinded-value world type-env vector-expr :vector) + (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) @@ -2147,7 +2827,7 @@ ; (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) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-kinded-value world type-env vector-expr :vector) + (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) (multiple-value-bind (n-code n-annotated-expr) (scan-typed-value world type-env n-expr (world-integer-type world)) (values (cond @@ -2168,7 +2848,7 @@ ; It is required that 0 <= low-expr <= high-expr+1 <= length. (defun scan-subseq (world type-env special-form vector-expr low-expr &optional high-expr) (let ((integer-type (world-integer-type world))) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-kinded-value world type-env vector-expr :vector) + (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) (multiple-value-bind (low-code low-annotated-expr) (scan-typed-value world type-env low-expr integer-type) (if high-expr (multiple-value-bind (high-code high-annotated-expr) (scan-typed-value world type-env high-expr integer-type) @@ -2190,7 +2870,7 @@ ; (append ) ; Returns a vector contatenating the two given vectors, which must have the same element type. (defun scan-append (world type-env special-form vector1-expr vector2-expr) - (multiple-value-bind (vector1-code vector-type vector1-annotated-expr) (scan-kinded-value world type-env vector1-expr :vector) + (multiple-value-bind (vector1-code vector-type vector1-annotated-expr) (scan-vector-value world type-env vector1-expr) (multiple-value-bind (vector2-code vector2-annotated-expr) (scan-typed-value world type-env vector2-expr vector-type) (values (if (eq vector-type (world-string-type world)) @@ -2204,7 +2884,7 @@ ; Returns a vector containing the same elements of the given vector except that the nth has been replaced ; with value-expr. n must be between 0 and length-1, inclusive. (defun scan-set-nth (world type-env special-form vector-expr n-expr value-expr) - (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-kinded-value world type-env vector-expr :vector) + (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) (multiple-value-bind (n-code n-annotated-expr) (scan-typed-value world type-env n-expr (world-integer-type world)) (multiple-value-bind (value-code value-annotated-expr) (scan-typed-value world type-env value-expr (vector-element-type vector-type)) (values @@ -2229,10 +2909,10 @@ ; (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-kinded-value world type-env vector-expr :vector) + (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-bindings type-env (list (cons var element-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)) @@ -2288,6 +2968,16 @@ (: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 + world type-env special-form element-type-expr + (mapcan #'(lambda (element-expr) + (list element-expr nil)) + element-exprs))) + + ; (set-of-ranges ... ) ; Makes a set of zero or more elements or element ranges. Each can be null to indicate a ; one-element range. @@ -2312,261 +3002,603 @@ (list* 'expr-annotation:special-form special-form element-type-expr element-annotated-exprs))))) -;;; Oneofs +;;; Tags -; (oneof ) -; oneof-type is inferred from the tag. -(defun scan-oneof-form (world type-env special-form tag &optional (value-expr nil has-value-expr)) - (multiple-value-bind (value-code value-type value-annotated-expr) - (if has-value-expr - (scan-value world type-env value-expr) - (values nil (world-void-type world) nil)) - (let ((type (lookup-oneof-tag world tag value-type))) - (values - `(cons ',tag ,value-code) - type - (list 'expr-annotation:special-form special-form tag value-annotated-expr type))))) +(defparameter *tag-counter* 0) - -; (typed-oneof ) -(defun scan-typed-oneof (world type-env special-form type-expr tag &optional (value-expr nil has-value-expr)) - (let ((type (scan-kinded-type world type-expr :oneof))) - (multiple-value-bind (tag field-type) (scan-tag type tag) - (multiple-value-bind (value-code value-annotated-expr) - (cond - (has-value-expr (scan-typed-value world type-env value-expr field-type)) - ((eq (type-kind field-type) :void) (values nil nil)) - (t (error "Missing oneof value expression"))) - (values - `(cons ',tag ,value-code) - type - (list 'expr-annotation:special-form special-form type-expr tag value-annotated-expr type)))))) - - -; (case ( ) ( ) ... ( )) -; where each is either or ( [:unused]) or (( ... )) -(defun scan-case (world type-env special-form oneof-expr &rest cases) - (multiple-value-bind (oneof-code oneof-type oneof-annotated-expr) (scan-kinded-value world type-env oneof-expr :oneof) - (let ((unseen-tags (copy-list (type-tags oneof-type))) - (case-codes nil) - (case-annotated-exprs nil) - (body-type nil) - (oneof-var (gensym "ONEOF"))) - (unless cases - (error "Empty case statement")) - (dolist (case cases) - (unless (and (consp case) (= (length case) 2)) - (error "Bad case ~S" case)) - (let ((tag-spec (first case)) - (tags nil) - (var nil) - (var-type-expr nil) - (local-type-env type-env)) - (cond - ((atom tag-spec) - (setq tags (list tag-spec))) - ((atom (first tag-spec)) - (unless (and (consp (cdr tag-spec)) - (consp (cddr tag-spec)) - (member (cdddr tag-spec) '(nil (:unused)) :test #'equal)) - (error "Bad case tag ~S" tag-spec)) - (setq tags (list (first tag-spec))) - (when (second tag-spec) - (setq var (scan-name world (second tag-spec))) - (setq var-type-expr (third tag-spec)))) - (t (when (rest tag-spec) - (error "Bad case tag ~S" tag-spec)) - (setq tags (first tag-spec)))) - (dolist (tag tags) - (multiple-value-bind (tag field-type) (scan-tag oneof-type tag) - (if (member tag unseen-tags) - (setq unseen-tags (delete tag unseen-tags)) - (error "Duplicate case tag ~A" tag)) - (when var - (let ((var-type (scan-type world var-type-expr))) - (unless (eq field-type var-type) - (error "Case tag ~A type mismatch: ~A and ~S" tag - (print-type-to-string field-type) var-type-expr)) - (setq local-type-env (type-env-add-bindings local-type-env (list (cons var field-type)))))))) - (multiple-value-bind (value-code value-type value-annotated-expr) (scan-value world local-type-env (second case)) - (if body-type - (let ((new-body-type (type-lub body-type value-type))) - (unless new-body-type - (error "Case result type mismatch: ~A and ~A" (print-type-to-string body-type) (print-type-to-string value-type))) - (setq body-type new-body-type)) - (setq body-type value-type)) - (push (list tags - (if var - `(let ((,var (cdr ,oneof-var))) - ,@(when (eq (fourth tag-spec) ':unused) - `((declare (ignore ,var)))) - ,value-code) - value-code)) - case-codes) - (push (list (list tags var var-type-expr) value-annotated-expr) case-annotated-exprs)))) - (when unseen-tags - (error "Missing case tags ~S" unseen-tags)) - (values - `(let ((,oneof-var ,oneof-code)) - (ecase (car ,oneof-var) ,@(nreverse case-codes))) - body-type - (list* 'expr-annotation:special-form special-form oneof-annotated-expr oneof-type (nreverse case-annotated-exprs)))))) - - -; (select ) -; Returns the tag's value or bottom if has a different tag. -(defun scan-select (world type-env special-form tag oneof-expr) - (multiple-value-bind (oneof-code oneof-type oneof-annotated-expr) (scan-kinded-value world type-env oneof-expr :oneof) - (multiple-value-bind (tag field-type) (scan-tag oneof-type tag) - (values - `(select-field ',tag ,oneof-code) - field-type - (list 'expr-annotation:special-form special-form tag oneof-annotated-expr oneof-type))))) - -(defun select-field (tag value) - (if (eq (car value) tag) - (cdr value) - (error "Select ~S got tag ~S" tag (car value)))) - - -; (is ) -(defun scan-is (world type-env special-form tag oneof-expr) - (multiple-value-bind (oneof-code oneof-type oneof-annotated-expr) (scan-kinded-value world type-env oneof-expr :oneof) - (let ((tag (scan-tag oneof-type tag))) - (values - `(eq ',tag (car ,oneof-code)) - (world-boolean-type world) - (list 'expr-annotation:special-form special-form tag oneof-annotated-expr oneof-type))))) - - -;;; Tuples - -; (tuple ... ) -(defun scan-tuple-form (world type-env special-form type-expr &rest value-exprs) - (let* ((type (scan-kinded-type world type-expr :tuple)) - (field-types (type-parameters type))) - (unless (= (length value-exprs) (length field-types)) - (error "Wrong number of tuple fields given in ~A constructor: ~S" (print-type-to-string type) value-exprs)) +; (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)) + (fields (tag-fields tag))) + (unless (= (length value-exprs) (length fields)) + (error "Wrong number of ~A fields given in constructor: ~S" tag-name value-exprs)) (multiple-value-map-bind (value-codes value-annotated-exprs) - #'(lambda (field-type value-expr) - (scan-typed-value world type-env value-expr field-type)) - (field-types value-exprs) + #'(lambda (field value-expr) + (scan-typed-value world type-env value-expr (field-type field))) + (fields value-exprs) (values - (cons 'list value-codes) + (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)))) type - (list* 'expr-annotation:special-form special-form type-expr type value-annotated-exprs))))) + (list* 'expr-annotation:special-form special-form tag value-annotated-exprs))))) -; (& ) -; Return the tuple field's value. -(defun scan-& (world type-env special-form tag tuple-expr) - (multiple-value-bind (tuple-code tuple-type tuple-annotated-expr) (scan-kinded-value world type-env tuple-expr :tuple) - (multiple-value-bind (tag field-type) (scan-tag tuple-type tag) +; (&