;;; The contents of this file are subject to the Mozilla Public ;;; License Version 1.1 (the "License"); you may not use this file ;;; except in compliance with the License. You may obtain a copy of ;;; the License at http://www.mozilla.org/MPL/ ;;; ;;; Software distributed under the License is distributed on an "AS ;;; IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or ;;; implied. See the License for the specific language governing ;;; rights and limitations under the License. ;;; ;;; The Original Code is the Language Design and Prototyping Environment. ;;; ;;; The Initial Developer of the Original Code is Netscape Communications ;;; Corporation. Portions created by Netscape Communications Corporation are ;;; Copyright (C) 1999 Netscape Communications Corporation. All ;;; Rights Reserved. ;;; ;;; Contributor(s): Waldemar Horwat ;;; ;;; ECMAScript semantic calculus ;;; ;;; 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 . 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)) ; 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 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. (declaim (inline not-eq)) (defun not-eq (a b) (not (eq a b))) (defun digit-char-36 (char) (assert-non-null (digit-char-p char 36))) ; Call map on each element of the list l. If map returns true, call filter on that element. Gather the results ; of the calls to filter into a new list and return that list. (defun filter-map-list (filter map l) (let ((results nil)) (dolist (e l) (when (funcall filter e) (push (funcall map e) results))) (nreverse results))) ; Call map on each element of the sequence s. If map returns true, call filter on that element. Gather the results ; of the calls to filter into a new sequence of type result-type and return that sequence. (defun filter-map (result-type filter map s) (let ((results nil)) (map nil #'(lambda (e) (when (funcall filter e) (push (funcall map e) results))) s) (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 (and float (not (eql 0.0)) (not (eql -0.0))) (member :+zero :-zero :+inf :-inf :nan))) (defun float64? (n) (or (and (floatp n) (not (zerop n))) (member n '(:+zero :-zero :+inf :-inf :nan)))) ; 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) (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) (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) (or (eq n :+zero) (eq n :-zero))) ; Return true if n is NaN and false otherwise. (declaim (inline float64-is-nan)) (defun float64-is-nan (n) (eq n :nan)) ; Return true if n is :+inf or :-inf and false otherwise. (declaim (inline float64-is-infinite)) (defun float64-is-infinite (n) (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) ((or (eq n :+inf) (eq m :-inf)) greater) ((or (eq m :+inf) (eq n :-inf)) less) ((< n m) less) ((> n m) greater) (t equal))) ; Return ; 1 if n is +0.0, :+inf, or any positive floating-point number; ; -1 if n is -0.0, :-inf, or any positive floating-point number; ; 0 if n is :nan. (defun float64-sign (n) (case n ((:+zero :+inf) 1) ((:-zero :-inf) -1) (:nan 0) (t (round (float-sign n))))) ; Return ; 0 if either n or m is :nan; ; 1 if n and m have the same float64-sign; ; -1 if n and m have different float64-signs. (defun float64-sign-xor (n m) (* (float64-sign n) (float64-sign m))) ; Return d truncated towards zero into a 32-bit integer. Overflows wrap around. (defun float64-to-uint32 (d) (case d ((:+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)))) ; Return -n. (defun float64-neg (n) (case n (:+zero :-zero) (:-zero :+zero) (:+inf :-inf) (:-inf :+inf) (:nan :nan) (t (- n)))) ; 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) (t :+inf))) (:-inf (case m ((:+inf :nan) :nan) (t :-inf))) (:nan :nan) (t (case m ((:+zero :-zero) n) (:+inf :+inf) (:-inf :-inf) (:nan :nan) (t (handle-overflow (+ n m) (let ((n-sign (float-sign n)) (m-sign (float-sign m))) (assert-true (= n-sign m-sign)) ;If the signs are opposite, we can't overflow. n-sign))))))) ; Return n-m. (defun float64-subtract (n m) (float64-add n (float64-neg m))) ; Return n*m. (defun float64-multiply (n m) (let ((sign (float64-sign-xor n m)) (n (float64-abs n)) (m (float64-abs m))) (let ((result (cond ((zerop sign) :nan) ((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) result)))) ; Return n/m. (defun float64-divide (n m) (let ((sign (float64-sign-xor n m)) (n (float64-abs n)) (m (float64-abs m))) (let ((result (cond ((zerop sign) :nan) ((eq n :+inf) (if (eq m :+inf) :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) result)))) ; Return n%m, using the ECMAScript definition of %. (defun float64-remainder (n m) (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 (let ((result (float (rem (rational n) (rational m))))) (if (zerop result) (if (minusp n) :-zero :+zero) result))))) ;;; ------------------------------------------------------------------------------------------------------ ;;; SET UTILITIES (defun integer-set-min (intset) (or (intset-min intset) (error "min of empty integer-set"))) (defun character-set-min (intset) (code-char (or (intset-min intset) (error "min of empty character-set")))) (defun integer-set-max (intset) (or (intset-max intset) (error "max of empty integer-set"))) (defun character-set-max (intset) (code-char (or (intset-max intset) (error "max of empty character-set")))) (defun integer-set-member (elt intset) (intset-member? intset elt)) (defun character-set-member (elt intset) (intset-member? intset (char-code elt))) ;;; ------------------------------------------------------------------------------------------------------ ;;; CODE GENERATION #+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 (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) (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)) (cddr stripped-function-value) (every #'(lambda (arg) (and (identifier? arg) (not (eql (first-symbol-char arg) #\&)))) (second stripped-function-value))) (let ((function-args (second stripped-function-value)) (function-body (cddr stripped-function-value))) (assert-true (= (length function-args) (length arg-values))) (if function-args (list* 'let (mapcar #'list function-args arg-values) function-body) (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 ; where possible. (defun gen-lambda (args body-code) (if args `#'(lambda ,args (declare (ignore-if-unused . ,args)) ,body-code) `#'(lambda () ,body-code))) ; If expr is a lambda-expression, return an equivalent expression that has ; the given name (which may be a symbol or a string; if it's a string, it is interned ; in the given package). Otherwise, return expr unchanged. ; Attaching a name to lambda-expressions helps in debugging code by identifying ; functions in debugger backtraces. (defun name-lambda (expr name &optional package) (if (and (consp expr) (eq (first expr) 'function) (consp (rest expr)) (consp (second expr)) (eq (first (second expr)) 'lambda) (null (cddr expr))) (let ((name (if (symbolp name) name (intern name package)))) ;Avoid trouble when name is a lisp special form like if or lambda. (when (special-form-p name) (setq name (gensym name))) `(flet ((,name ,@(rest (second expr)))) #',name)) expr)) ; Intern n symbols in the current package with names 0, 1, ..., ; n-1, where is the value of the prefix string. ; Return a list of these n symbols concatenated to the front of rest. (defun intern-n-vars-with-prefix (prefix n rest) (if (zerop n) rest (intern-n-vars-with-prefix prefix (1- n) (cons (intern (format nil "~A~D" prefix n)) rest)))) ; Make a new function with the given name. The function takes n-args arguments and applies them to the ; function whose source code is in expr. Return the source code for the function. (defun gen-defun (expr name n-args) (when (special-form-p name) (error "Can't call make-defun on ~S" name)) (if (and (consp expr) (eq (first expr) 'function) (consp (rest expr)) (second expr) (null (cddr expr)) (let ((stripped-expr (second expr))) (and (consp stripped-expr) (eq (first stripped-expr) 'lambda) (listp (second stripped-expr)) (cddr stripped-expr) (every #'(lambda (arg) (and (identifier? arg) (not (eql (first-symbol-char arg) #\&)))) (second stripped-expr))))) (let* ((stripped-expr (second expr)) (function-args (second stripped-expr)) (function-body (cddr stripped-expr))) (assert-true (= (length function-args) n-args)) (list* 'defun name function-args function-body)) (let ((args (intern-n-vars-with-prefix "_" n-args nil))) (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) (error "Can't call make-defun on ~S" name)) (if (and (consp expr) (eq (first expr) 'function) (consp (rest expr)) (second expr) (null (cddr expr)) (let ((stripped-expr (second expr))) (and (consp stripped-expr) (eq (first stripped-expr) 'lambda) (listp (second stripped-expr)) (cddr stripped-expr)))) (second expr) (let ((args (intern-n-vars-with-prefix "_" n-args nil))) (list 'lambda args (apply #'gen-apply expr args))))) ;;; ------------------------------------------------------------------------------------------------------ ;;; LF TOKENS ;;; Each symbol in the LF package is a variant of a terminal that represents that terminal preceded by one ;;; or more line breaks. (defvar *lf-package* (make-package "LF" :use nil)) (defun make-lf-terminal (terminal) (assert-true (not (lf-terminal? terminal))) (multiple-value-bind (lf-terminal present) (intern (symbol-name terminal) *lf-package*) (unless (eq present :external) (export lf-terminal *lf-package*) (setf (get lf-terminal :sort-key) (concatenate 'string (symbol-name terminal) " ")) (setf (get lf-terminal :origin) terminal) (setf (get terminal :lf-terminal) lf-terminal)) lf-terminal)) (defun lf-terminal? (terminal) (eq (symbol-package terminal) *lf-package*)) (declaim (inline terminal-lf-terminal lf-terminal-terminal)) (defun terminal-lf-terminal (terminal) (get terminal :lf-terminal)) (defun lf-terminal-terminal (lf-terminal) (get lf-terminal :origin)) ; Ensure that for each transition on a LF: terminal in the grammar there exists a corresponding transition ; on a non-LF: terminal. (defun ensure-lf-subset (grammar) (all-state-transitions #'(lambda (state transitions-hash) (dolist (transition-pair (state-transitions state)) (let ((terminal (car transition-pair))) (when (lf-terminal? terminal) (unless (equal (cdr transition-pair) (gethash (lf-terminal-terminal terminal) transitions-hash)) (format *error-output* "State ~S: transition on ~S differs from transition on ~S~%" state terminal (lf-terminal-terminal terminal))))))) grammar)) ; Print a list of transitions on non-LF: terminals that do not have corresponding LF: transitions. ; Return a list of non-LF: terminals which behave identically to the corresponding LF: terminals. (defun show-non-lf-only-transitions (grammar) (let ((invariant-terminalset (make-full-terminalset grammar)) (terminals-vector (grammar-terminals grammar))) (dotimes (n (length terminals-vector)) (let ((terminal (svref terminals-vector n))) (when (lf-terminal? terminal) (terminalset-difference-f invariant-terminalset (make-terminalset grammar terminal))))) (all-state-transitions #'(lambda (state transitions-hash) (dolist (transition-pair (state-transitions state)) (let ((terminal (car transition-pair))) (unless (lf-terminal? terminal) (let ((lf-terminal (terminal-lf-terminal terminal))) (when lf-terminal (let ((lf-terminal-transition (gethash lf-terminal transitions-hash))) (cond ((null lf-terminal-transition) (terminalset-difference-f invariant-terminalset (make-terminalset grammar terminal)) (format *error-output* "State ~S has transition on ~S but not on ~S~%" state terminal lf-terminal)) ((not (equal (cdr transition-pair) lf-terminal-transition)) (terminalset-difference-f invariant-terminalset (make-terminalset grammar terminal)) (format *error-output* "State ~S transition on ~S differs from transition on ~S~%" state terminal lf-terminal)))))))))) grammar) (terminalset-list grammar invariant-terminalset))) ;;; ------------------------------------------------------------------------------------------------------ ;;; GRAMMAR-INFO (defstruct (grammar-info (:constructor make-grammar-info (name grammar &optional lexer)) (:copier nil) (:predicate grammar-info?)) (name nil :type symbol :read-only t) ;The name of this grammar (grammar nil :type grammar :read-only t) ;This grammar (lexer nil :type (or null lexer) :read-only t)) ;This grammar's lexer if this is a lexer grammar; nil if not ; Return the charclass that defines the given lexer nonterminal or nil if none. (defun grammar-info-charclass (grammar-info nonterminal) (let ((lexer (grammar-info-lexer grammar-info))) (and lexer (lexer-charclass lexer nonterminal)))) ; Return the charclass or partition that defines the given lexer nonterminal or nil if none. (defun grammar-info-charclass-or-partition (grammar-info nonterminal) (let ((lexer (grammar-info-lexer grammar-info))) (and lexer (or (lexer-charclass lexer nonterminal) (gethash nonterminal (lexer-partitions lexer)))))) ;;; ------------------------------------------------------------------------------------------------------ ;;; WORLDS (defstruct (world (:constructor allocate-world) (:copier nil) (: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 (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 (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 ; Return the name of the world. (defun world-name (world) (package-name (world-package world))) ; Return a symbol in the given package whose value is that package's world structure. (defun world-access-symbol (package) (find-symbol "*WORLD*" package)) ; Return the world that created the given package. (declaim (inline package-world)) (defun package-world (package) (symbol-value (world-access-symbol package))) ; Return the world that contains the given symbol. (defun symbol-world (symbol) (package-world (symbol-package symbol))) ; Delete the world and its package. (defun delete-world (world) (let ((package (world-package world))) (when package (delete-package package))) (setf (world-package world) nil)) ; Create a world using a package with the given name. ; If the package is already used for another world, its contents ; are erased and the other world deleted. (defun make-world (name) (assert-type name string) (let ((p (find-package name))) (when p (let* ((access-symbol (world-access-symbol p)) (p-world (and (boundp access-symbol) (symbol-value access-symbol)))) (unless p-world (error "Package ~A already in use" name)) (assert-true (eq (world-package p-world) p)) (delete-world p-world)))) (let* ((p (make-package name :use nil)) (world (allocate-world :package p :types-reverse (make-hash-table :test #'equal))) (access-symbol (intern "*WORLD*" p))) (set access-symbol world) (export access-symbol p) world)) ; Intern s (which should be a symbol or a string) in this world's ; package and return the resulting symbol. (defun world-intern (world s) (intern (string s) (world-package world))) ; Same as world-intern except that return nil if s is not already interned. (defun world-find-symbol (world s) (find-symbol (string s) (world-package world))) ; Export symbol in its package, which must belong to some world. (defun export-symbol (symbol) (assert-true (symbol-in-any-world symbol)) (export symbol (symbol-package symbol))) ; Call f on each external symbol defined in the world's package. (declaim (inline each-world-external-symbol)) (defun each-world-external-symbol (world f) (each-package-external-symbol (world-package world) f)) ; Call f on each external symbol defined in the world's package that has ; a property with the given name. ; f takes two arguments: ; the symbol ; the value of the property (defun each-world-external-symbol-with-property (world property f) (each-world-external-symbol world #'(lambda (symbol) (let ((value (get symbol property *get2-nonce*))) (unless (eq value *get2-nonce*) (funcall f symbol value)))))) ; Return a list of all external symbols defined in the world's package that have ; a property with the given name. ; The list is sorted by symbol names. (defun all-world-external-symbols-with-property (world property) (let ((list nil)) (each-world-external-symbol world #'(lambda (symbol) (let ((value (get symbol property *get2-nonce*))) (unless (eq value *get2-nonce*) (push symbol list))))) (sort list #'string<))) ; Return true if s is a symbol that is defined in this world's package. (declaim (inline symbol-in-world)) (defun symbol-in-world (world s) (and (symbolp s) (eq (symbol-package s) (world-package world)))) ; Return true if s is a symbol that is defined in any world's package. (defun symbol-in-any-world (s) (and (symbolp s) (let* ((package (symbol-package s)) (access-symbol (world-access-symbol package))) (and (boundp access-symbol) (typep (symbol-value access-symbol) 'world))))) ; Return a list of grammars in the world (defun world-grammars (world) (mapcar #'grammar-info-grammar (world-grammar-infos world))) ; Return the grammar-info with the given name in the world (defun world-grammar-info (world name) (find name (world-grammar-infos world) :key #'grammar-info-name)) ; Return the grammar with the given name in the world (defun world-grammar (world name) (let ((grammar-info (world-grammar-info world name))) (assert-non-null (and grammar-info (grammar-info-grammar grammar-info))))) ; Return the lexer with the given name in the world (defun world-lexer (world name) (let ((grammar-info (world-grammar-info world name))) (assert-non-null (and grammar-info (grammar-info-lexer grammar-info))))) ; Return a list of highlights allowed in this world. (defun world-highlights (world) (let ((highlights nil)) (dolist (c (world-conditionals world)) (let ((highlight (cdr c))) (unless (or (null highlight) (eq highlight 'delete)) (pushnew highlight highlights)))) (nreverse highlights))) ; Return the highlight to which the given conditional maps. ; Return 'delete if the conditional should be omitted. (defun resolve-conditional (world conditional) (let ((h (assoc conditional (world-conditionals world)))) (if h (cdr h) (error "Bad conditional ~S" conditional)))) ;;; ------------------------------------------------------------------------------------------------------ ;;; SYMBOLS ;;; The following properties are attached to exported symbols in the world: ;;; ;;; :preprocess preprocessor function ((preprocessor-state id . form-arg-list) -> form-list re-preprocess) if this identifier ;;; is a preprocessor command like 'grammar, 'lexer, or 'production ;;; ;;; :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 'tag or 'in ;;; ;;; :primitive primitive structure if this identifier is a primitive ;;; ;;; :type-constructor expression code generation function ((world allow-forward-references . form-arg-list) -> type) if this ;;; identifier is a type constructor like '->, 'vector, 'set, 'tag, or 'union ;;; :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 -> ;;; :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-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-type-constructor depictor function ((markup-stream world level . form-arg-list) -> void) ;;; ; 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 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 ; (or nil if not specified). ; This macro is appropriate for use with setf. (defmacro symbol-type-definition (symbol &optional default) `(get ,symbol :deftype ,@(and default (list default)))) ; Return true if this symbol's symbol-type-definition is user-defined. ; This macro is appropriate for use with setf. (defmacro symbol-type-user-defined (symbol) `(get ,symbol 'type-user-defined)) ; Call f on each type definition, including forward-referenced types, in the world. ; f takes two arguments: ; the symbol ; the type (nil if forward-referenced) (defun each-type-definition (world f) (each-world-external-symbol-with-property world :deftype f)) ; Return a sorted list of the names of all type definitions, including ; forward-referenced types, in the world. (defun world-type-definitions (world) (all-world-external-symbols-with-property world :deftype)) ; Return the type of the variable associated with the given symbol or nil if none. ; This macro is appropriate for use with setf. (defmacro symbol-type (symbol) `(get ,symbol :type)) ; 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. (defmacro symbol-action (symbol) `(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 ;tag ;parameters :bottom ;nil ;nil :void ;nil ;nil :boolean ;nil ;nil :integer ;nil ;nil :rational ;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) :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. (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 (serial-number nil :type integer) ;This type's unique serial number (kind nil :type typekind :read-only t) ;This type's kind (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) nil nil)) (declaim (inline ->-argument-types)) (defun ->-argument-types (type) (assert-true (eq (type-kind type) :->)) (cdr (type-parameters type))) (declaim (inline ->-result-type)) (defun ->-result-type (type) (assert-true (eq (type-kind type) :->)) (car (type-parameters type))) (declaim (inline make-vector-type)) (defun make-vector-type (world 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 (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) 'intset= nil)) (declaim (inline set-element-type)) (defun set-element-type (type) (assert-true (eq (type-kind type) :set)) (car (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 always-true)) (defun always-true (a b) (declare (ignore a b)) t) (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 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))) (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 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))) ; 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 ; the type's top level even if it has a name. In all other cases expand ; anonymous types but abbreviate named types by their names. (defun print-type (type &optional (stream t) expand1) (if (and (type-name type) (not expand1)) (write-string (symbol-name (type-name 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) (loop (print-type (pprint-pop) stream) (pprint-exit-if-list-exhausted) (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 ; and returns that string. (defun print-type-to-string (type &optional expand1) (with-output-to-string (stream) (print-type type stream expand1))) (defmethod print-object ((type type) stream) (print-unreadable-object (type stream) (format stream "type~D ~@_" (type-serial-number type)) (let ((name (type-name type))) (when name (format stream "~A = ~@_" name))) (print-type type stream t))) ; 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 tag parameters =-name /=-name) (let ((reverse-key (list kind tag parameters))) (or (gethash reverse-key (world-types-reverse world)) (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))))) ; Provide a new symbol for the type. A type can have zero or more names. ; Signal an error if the name is already used. ; user-defined is true if this is a user-defined type rather than a predefined type. (defun add-type-name (world type symbol user-defined) (assert-true (symbol-in-world world symbol)) (when (symbol-type-definition symbol) (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 (symbol-type-definition symbol) type) (when user-defined (setf (symbol-type-user-defined symbol) t)) (export-symbol symbol)) ; Return an existing type with the given symbol, which must be interned in a world's package. ; Signal an error if there isn't an existing type. If allow-forward-references is true and ; symbol is an undefined type identifier, allow it, create a forward-referenced type, and return symbol. (defun get-type (symbol &optional allow-forward-references) (or (symbol-type-definition symbol) (if allow-forward-references (progn (setf (symbol-type-definition symbol) nil) symbol) (error "Undefined type ~A" symbol)))) ; Scan a type-expr to produce a type. Return that type. ; If allow-forward-references is true and type-expr is an undefined type identifier, ; allow it, create a forward-referenced type in the world, and return type-expr unchanged. ; If allow-forward-references is true, also allow undefined type ; identifiers deeper within type-expr (anywhere except at its top level). ; If type-expr is already a type, return it unchanged. (defun scan-type (world type-expr &optional allow-forward-references) (cond ((identifier? type-expr) (get-type (world-intern world type-expr) allow-forward-references)) ((type? type-expr) type-expr) (t (let ((type-constructor (and (consp type-expr) (symbolp (first type-expr)) (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)))))) ; Same as scan-type except that ensure that the type has the expected kind. ; Return the type. (defun scan-kinded-type (world type-expr expected-type-kind) (let ((type (scan-type world type-expr))) (unless (eq (type-kind type) expected-type-kind) (error "Expected ~(~A~) but got ~A" expected-type-kind (print-type-to-string type))) type)) ; (-> ( ... ) ) (defun scan--> (world allow-forward-references arg-type-exprs result-type-expr) (unless (listp arg-type-exprs) (error "Bad -> argument type list ~S" arg-type-exprs)) (make-->-type world (mapcar #'(lambda (te) (scan-type world te allow-forward-references)) arg-type-exprs) (scan-type world result-type-expr allow-forward-references))) ; (vector ) (defun scan-vector (world allow-forward-references element-type) (make-vector-type world (scan-type world element-type allow-forward-references))) ; (set ) (defun scan-set (world allow-forward-references element-type) (make-set-type world (scan-type world element-type allow-forward-references))) ; (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)))) ; (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. ; Signal an error if any unresolved type references remain. ; Only types reachable from some type name are affected. It is the caller's ; responsibility to make sure that these are the only types that exist. ; Return a list of all type structures encountered. (defun resolve-forward-types (world) (setf (world-types-reverse world) nil) (let ((visited-types (make-hash-table :test #'eq))) (labels ((resolve-in-type (type) (unless (gethash type visited-types) (setf (gethash type visited-types) t) (do ((parameter-types (type-parameters type) (cdr parameter-types))) ((endp parameter-types)) (let ((parameter-type (car parameter-types))) (unless (typep parameter-type 'type) (setq parameter-type (get-type parameter-type)) (setf (car parameter-types) parameter-type)) (resolve-in-type parameter-type)))))) (each-type-definition world #'(lambda (symbol type) (unless type (error "Undefined type ~A" symbol)) (resolve-in-type type)))) (hash-table-keys visited-types))) ; 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))) (labels ((visit-type (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) (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) (declare (ignore symbol)) (visit-type type)))) (setf (world-types-reverse world) types-reverse))) ; Make all equivalent types be eq. Only types reachable from some type name ; 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 (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 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)) (n-types (length types))) (labels ((gen-cliques-1 (get-key) (let ((types-to-cliques (make-hash-table :test #'eq :size n-types)) (keys-to-cliques (make-hash-table :test #'equal)) (n-cliques 0)) (dolist (type types) (let* ((key (funcall get-key type)) (clique (gethash key keys-to-cliques))) (unless clique (setq clique n-cliques) (incf n-cliques) (setf (gethash key keys-to-cliques) clique)) (setf (gethash type types-to-cliques) clique))) (values n-cliques types-to-cliques))) (gen-cliques (n-old-cliques types-to-old-cliques) (labels ((get-old-clique (type) (assert-non-null (gethash type types-to-old-cliques))) (get-type-key (type) (cons (get-old-clique type) (mapcar #'get-old-clique (type-parameters type))))) (multiple-value-bind (n-new-cliques types-to-new-cliques) (gen-cliques-1 #'get-type-key) (assert-true (>= n-new-cliques n-old-cliques)) (if (/= n-new-cliques n-old-cliques) (gen-cliques n-new-cliques types-to-new-cliques) (translate-types n-new-cliques types-to-new-cliques))))) (translate-types (n-cliques types-to-cliques) (let ((clique-representatives (make-array n-cliques :initial-element nil))) (maphash #'(lambda (type clique) (let ((representative (svref clique-representatives clique))) (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)) (labels ((map-type (type) (svref clique-representatives (gethash type types-to-cliques)))) (dolist (type types) (do ((parameter-types (type-parameters type) (cdr parameter-types))) ((endp parameter-types)) (setf (car parameter-types) (map-type (car parameter-types))))) (each-type-definition world #'(lambda (symbol type) (setf (symbol-type-definition symbol) (map-type type)))))))) (multiple-value-call #'gen-cliques (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 (defun checked-callable (f) (let ((fun (callable f))) (unless fun (warn "Undefined function ~S" f)) fun)) ; 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 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. ; ; 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 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 '((:command . :depict-command) (:statement . :depict-statement) (:special-form . :depict-special-form) (:type-constructor . :depict-type-constructor)))))) (assert-true (or emit-property (not depictor))) (assert-type symbol identifier) (when *value-asserts* (checked-callable expander) (when depictor (checked-callable depictor))) (when (or (get symbol property) (and emit-property (get symbol emit-property))) (error "Attempt to redefine ~A ~A" property symbol)) (setf (get symbol property) expander) (when emit-property (if depictor (setf (get symbol emit-property) depictor) (remprop symbol emit-property))) (export-symbol symbol))) ;;; ------------------------------------------------------------------------------------------------------ ;;; PRIMITIVES (defstruct (primitive (:constructor make-primitive (type-expr value-code appearance &key markup1 markup2 level level1 level2)) (:predicate primitive?)) (type nil :type (or null type)) ;Type of this primitive; nil if not computed yet (type-expr nil :read-only t) ;Source type expression that designates the type of this primitive (value-code nil :read-only t) ;Lisp expression that computes the value of this primitive (appearance nil :read-only t) ;One of the possible primitive appearances (see below) (markup1 nil :read-only t) ;Markup (item or list) for this primitive (markup2 nil :read-only t) ;:global primitives: name to use for an external reference ; ;:unary primitives: markup (item or list) for this primitive's closer ; ;:infix primitives: true if spaces should be put around primitive (level nil :read-only t) ;Precedence level of markup for this primitive (level1 nil :read-only t) ;Precedence level required for first argument of this primitive (level2 nil :read-only t)) ;Precedence level required for second argument of this primitive ;appearance is one of the following: ; :global The primitive appears as a regular, global function or constant; its markup is in markup1. ; If this primitive should generate an external reference, markup2 contains the name to use for the reference ; :infix The primitive is an infix binary primitive; its markup is in markup1; if markup2 is true, put spaces around markup1 ; :unary The primitive is a prefix and/or suffix unary primitive; the prefix is in markup1 and suffix in markup2 ; :phantom The primitive disappears when emitting markup for it ; Call this to declare all primitives when initially constructing a world, ; before types have been constructed. (defun declare-primitive (symbol type-expr value-code appearance &rest key-args) (when (symbol-primitive symbol) (error "Attempt to redefine primitive ~A" symbol)) (setf (symbol-primitive symbol) (apply #'make-primitive type-expr value-code appearance key-args)) (export-symbol symbol)) ; Call this to compute the primitive's type from its type-expr. (defun define-primitive (world primitive) (setf (primitive-type primitive) (scan-type world (primitive-type-expr primitive)))) ; 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 :statement :special-form :primitive :type-constructor)) (error "~A is reserved" symbol)) symbol)) ;;; ------------------------------------------------------------------------------------------------------ ;;; TYPE ENVIRONMENTS ;;; A type environment is an alist that associates bound variables with their types. ;;; A variable may be bound multiple times; the first binding in the environment list ;;; shadows ones further in the list. ;;; The following kinds of bindings are allowed in a type environment: ;;; ;;; (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. ;;; (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 its binding; if not, return nil. ; symbol must already be world-interned. (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 ; instances of the given grammar-symbol's symbol on the right-hand side, and if action is ; a legal action for that symbol, return three values: ; the name to use from the generated lisp code to refer to the result of calling ; the action on the index-th instance of this symbol; ; the action result's type; ; 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-get-action (type-env action symbol index) (assoc (list* action symbol index) type-env :test #'equal)) ; 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)) ; 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))) ; 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))) ;;; ------------------------------------------------------------------------------------------------------ ;;; VALUES ;;; A value is one of the following: ;;; A void value (represented by nil) ;;; A boolean (nil for false; non-nil for true) ;;; An integer ;;; A rational number ;;; A double-precision floating-point number (or :+inf, :-inf, or :nan) ;;; 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 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. ; 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 ; 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-type (value type &optional shallow) (case (type-kind type) (:bottom nil) (:void t) (:boolean t) (:integer (integerp value)) (:rational (rationalp value)) (:finite64 (and (floatp value) (not (zerop value)))) (:character (characterp value)) (:-> (functionp value)) (:string (stringp value)) (:vector (let ((element-type (vector-element-type type))) (labels ((test (value) (or (null value) (and (consp value) (or shallow (value-has-type (car value) element-type)) (test (cdr value)))))) (test value)))) (:set (valid-intset? value)) (: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))))) ; Print the value nicely on the given stream. type is the value's type. (defun print-value (value type &optional (stream t)) (assert-true (value-has-type value type t)) (case (type-kind type) (:void (assert-true (null value)) (write-string "empty" stream)) (:boolean (write-string (if value "true" "false") 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))) (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) (format stream " ~:_"))))) (:set (let ((converter (set-out-converter (set-element-type type)))) (pprint-logical-block (stream value :prefix "{" :suffix "}") (pprint-exit-if-list-exhausted) (loop (let* ((values (pprint-pop)) (value1 (car values)) (value2 (cdr values))) (if (= value1 value2) (write (funcall converter value1) :stream stream) (write (list (funcall converter value1) (funcall converter value2)) :stream stream)))) (pprint-exit-if-list-exhausted) (format stream " ~:_")))) (: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 (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))))) ; Print a list of values nicely on the given stream. types is the list of the ; values' types (and should have the same length as the list of values). ; If prefix and/or suffix are non-null, use them as beginning and ending ; delimiters of the printed list. (defun print-values (values types &optional (stream t) &key prefix suffix) (assert-true (= (length values) (length types))) (pprint-logical-block (stream values :prefix prefix :suffix suffix) (pprint-exit-if-list-exhausted) (dolist (type types) (print-value (pprint-pop) type stream) (pprint-exit-if-list-exhausted) (format stream " ~:_")))) ;;; ------------------------------------------------------------------------------------------------------ ;;; VALUE EXPRESSIONS ;;; Expressions are annotated to avoid having to duplicate the expression scanning logic when ;;; emitting markup for expressions. Expression forms are prefixed with an expr-annotation symbol ;;; to indicate their kinds. These symbols are in their own package to avoid potential confusion ;;; with keywords, variable names, terminals, etc. ;;; ;;; Some special forms are extended to include parsed type information for the benefit of markup logic. (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage "EXPR-ANNOTATION" (:use) (: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? (world special-form annotated-expr) (and (eq (first annotated-expr) 'expr-annotation:special-form) (eq (second annotated-expr) (world-find-symbol world special-form)))) ; Return the value of the variable with the given symbol. ; Compute the value if the variable was unbound. ; Use the *busy-variables* list to prevent infinite recursion while computing variable values. (defmacro fetch-value (symbol) `(if (boundp ',symbol) (symbol-value ',symbol) (compute-variable-value ',symbol))) ; Generate a lisp expression that will compute the value of value-expr. ; type-env is the type environment. The expression may refer to free variables ; present in the type-env. ; Return three values: ; The expression's value (a lisp expression) ; The expression's type ; The annotated value-expr (defun scan-value (world type-env value-expr) (labels ((syntax-error () (error "Syntax error: ~S" value-expr)) ;Scan a function call. The function has already been scanned into its value and type, ;but the arguments are still unprocessed. (scan-call (function-value function-type function-annotated-expr arg-exprs) (let ((arg-values nil) (arg-types nil) (arg-annotated-exprs nil)) (dolist (arg-expr arg-exprs) (multiple-value-bind (arg-value arg-type arg-annotated-expr) (scan-value world type-env arg-expr) (push arg-value arg-values) (push arg-type arg-types) (push arg-annotated-expr arg-annotated-exprs))) (let ((arg-values (nreverse arg-values)) (arg-types (nreverse arg-types)) (arg-annotated-exprs (nreverse 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)) (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-get-action type-env action symbol 2))) (when (and (not index-supplied) multiple-symbols) (error "Ambiguous index in action ~S" (list action 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 (get-type-env-flag type-env :lhs-symbol)))) (list index))))))) ;Scan an interned identifier (scan-identifier (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 ((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 special form (scan-cons (first rest) (if (identifier? first) (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) (values value-expr type (list 'expr-annotation:constant value-expr)))) (assert-three-values (cond ((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) (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 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) (values (widening-coercion-code world expected-type type value value-expr) annotated-expr))) ; 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-vector-value (world type-env value-expr) (multiple-value-bind (value type annotated-expr) (scan-value world type-env value-expr) (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) (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))) ; 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)))) (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)) (quiet-compile symbol code)))) (defvar *busy-variables* nil) ; Compute the value of a world's variable named by symbol. Return the variable's value. ; If the variable already has a computed value, return it unchanged. The variable's type must not be ->. ; If computing the value requires the values of other variables, compute them as well. ; Use the *busy-variables* list to prevent infinite recursion while computing variable values. (defun compute-variable-value (symbol) (cond ((member symbol *busy-variables*) (error "Definition of ~A refers to itself" symbol)) ((boundp symbol) (symbol-value symbol)) ((fboundp symbol) (error "compute-variable-value should be called only once on a function")) (t (let* ((*busy-variables* (cons symbol *busy-variables*)) (value-expr (get symbol :value-expr)) (type (symbol-type symbol))) (handler-bind (((or error warning) #'(lambda (condition) (declare (ignore condition)) (format *error-output* "~&~@<~2IWhile computing ~A: ~_~:W~:>~%" symbol value-expr)))) (assert-true (not (eq (type-kind type) :->))) (let ((value-code (scan-global-value symbol value-expr type))) (when *trace-variables* (format *trace-output* "~&~S := ~:W~%" symbol value-code)) (set symbol (eval value-code)))))))) ;;; ------------------------------------------------------------------------------------------------------ ;;; SPECIAL FORMS ;;; Constants (defun eval-bottom () (error "Reached a BOTTOM expression")) ; (bottom) ; (todo) ; Raises an error. (defun scan-bottom (world type-env special-form) (declare (ignore type-env)) (values '(eval-bottom) (world-bottom-type world) (list 'expr-annotation:special-form special-form))) ; (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)) (declare (ignore type-env)) (unless (and (integerp n) (integerp length) (>= length 0)) (error "Bad hex constant ~S [~S]" n length)) (values n (world-integer-type world) (list 'expr-annotation:special-form special-form n length))) ;;; Expressions (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-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) (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 (defmacro non-empty-vector (v operation-name) `(or ,v (error ,(concatenate 'string operation-name " called on empty 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-expr (world type-env special-form element-expr &rest element-exprs) (multiple-value-bind (element-code element-type element-annotated-expr) (scan-value world type-env element-expr) (multiple-value-map-bind (rest-codes rest-annotated-exprs) #'(lambda (element-expr) (scan-typed-value world type-env element-expr element-type)) (element-exprs) (make-vector-expr world special-form element-type (cons element-code rest-codes) (cons element-annotated-expr rest-annotated-exprs))))) ; (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))) (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 ) ; Returns true if the vector has zero elements. ; This is equivalent to (= (length ) 0) and depicts the same as the latter but ; is implemented more efficiently. (defun scan-empty (world type-env special-form vector-expr) (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) (values (if (eq vector-type (world-string-type world)) `(= (length ,vector-code) 0) (list 'endp vector-code)) (world-boolean-type world) (list 'expr-annotation:special-form special-form vector-annotated-expr)))) ; (length ) ; Returns the number of elements in the vector. (defun scan-length (world type-env special-form vector-expr) (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) (declare (ignore vector-type)) (values (list 'length vector-code) (world-integer-type world) (list 'expr-annotation:special-form special-form vector-annotated-expr)))) ; (nth ) ; Returns the nth element of the vector. Throws an error if the vector's length is less than n. (defun scan-nth (world type-env special-form vector-expr n-expr) (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 ((eq vector-type (world-string-type world)) `(char ,vector-code ,n-code)) ((eql n-code 0) `(car (non-empty-vector ,vector-code "first"))) (t (let ((n (gensym "N"))) `(let ((,n ,n-code)) (car (non-empty-vector (nthcdr ,n ,vector-code) "nth")))))) (vector-element-type vector-type) (list 'expr-annotation:special-form special-form vector-annotated-expr n-annotated-expr))))) ; (subseq []) ; Returns a vector containing elements of the given vector from low-expr to high-expr inclusive. ; high-expr defaults to length-1. ; 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-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) (values `(subseq ,vector-code ,low-code (1+ ,high-code)) vector-type (list 'expr-annotation:special-form special-form vector-annotated-expr low-annotated-expr high-annotated-expr))) (values (case low-code (0 vector-code) (1 (if (eq vector-type (world-string-type world)) `(subseq ,vector-code 1) `(cdr (non-empty-vector ,vector-code "rest")))) (t `(subseq ,vector-code ,low-code))) vector-type (list 'expr-annotation:special-form special-form vector-annotated-expr low-annotated-expr nil))))))) ; (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-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)) `(concatenate 'string ,vector1-code ,vector2-code) (list 'append vector1-code vector2-code)) vector-type (list 'expr-annotation:special-form special-form vector1-annotated-expr vector2-annotated-expr))))) ; (set-nth ) ; 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-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 (let ((vector (gensym "V")) (n (gensym "N"))) `(let ((,vector ,vector-code) (,n ,n-code)) (if (or (< ,n 0) (>= ,n (length ,vector))) (error "Range error") ,(if (eq vector-type (world-string-type world)) `(progn (setq ,vector (copy-seq ,vector)) (setf (char ,vector ,n) ,value-code) ,vector) (let ((l (gensym "L"))) `(let ((,l (nthcdr ,n ,vector))) (append (ldiff ,vector ,l) (cons ,value-code (cdr ,l))))))))) vector-type (list 'expr-annotation:special-form special-form vector-annotated-expr n-annotated-expr value-annotated-expr)))))) ; (map []) (defun scan-map (world type-env special-form vector-expr var-source value-expr &optional (condition-expr 'true)) (multiple-value-bind (vector-code vector-type vector-annotated-expr) (scan-vector-value world type-env vector-expr) (let* ((var (scan-name world var-source)) (element-type (vector-element-type vector-type)) (local-type-env (type-env-add-binding type-env var element-type :const))) (multiple-value-bind (value-code value-type value-annotated-expr) (scan-value world local-type-env value-expr) (multiple-value-bind (condition-code condition-annotated-expr) (scan-typed-value world local-type-env condition-expr (world-boolean-type world)) (let* ((result-type (make-vector-type world value-type)) (source-is-string (eq element-type (world-character-type world))) (destination-is-string (eq value-type (world-character-type world))) (destination-sequence-type (if destination-is-string 'string 'list)) (result-annotated-expr (list 'expr-annotation:special-form special-form vector-annotated-expr var value-annotated-expr condition-annotated-expr))) (cond ((eq condition-code 't) (values (if (or source-is-string destination-is-string) `(map ',destination-sequence-type #'(lambda (,var) ,value-code) ,vector-code) `(mapcar #'(lambda (,var) ,value-code) ,vector-code)) result-type (nbutlast result-annotated-expr))) ((eq value-expr var-source) (assert-true (eq value-type element-type)) (values `(remove-if-not #'(lambda (,var) ,condition-code) ,vector-code) result-type result-annotated-expr)) (t (values (if (or source-is-string destination-is-string) `(filter-map ',destination-sequence-type #'(lambda (,var) ,condition-code) #'(lambda (,var) ,value-code) ,vector-code) `(filter-map-list #'(lambda (,var) ,condition-code) #'(lambda (,var) ,value-code) ,vector-code)) result-type result-annotated-expr))))))))) ;;; Sets ; Return a function that converts values of the given element-type to integers for storage in a set. (defun set-in-converter (element-type) (ecase (type-kind element-type) (:integer #'identity) (:character #'char-code))) ; expr is the source code of an expression that generates a value of the given element-type. Return ; the source code of an expression that generates the corresponding integer for storage in a set of ; the given element-type. (defun set-in-converter-expr (element-type expr) (ecase (type-kind element-type) (:integer expr) (:character (list 'char-code expr)))) ; Return a function that converts integers to values of the given element-type for retrieval from a set. (defun set-out-converter (element-type) (ecase (type-kind element-type) (:integer #'identity) (:character #'code-char))) ; (set-of ... ) ==> ; (set-of-ranges nil ... nil) (defun scan-set-of (world type-env special-form element-type-expr &rest element-exprs) (apply #'scan-set-of-ranges 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. (defun scan-set-of-ranges (world type-env special-form element-type-expr &rest element-exprs) (let* ((element-type (scan-type world element-type-expr)) (high t)) (multiple-value-map-bind (element-codes element-annotated-exprs) #'(lambda (element-expr) (setq high (not high)) (if (and high (null element-expr)) (values nil nil) (multiple-value-bind (element-code element-annotated-expr) (scan-typed-value world type-env element-expr element-type) (values (set-in-converter-expr element-type element-code) element-annotated-expr)))) (element-exprs) (unless high (error "Odd number of set-of-ranges elements: ~S" element-exprs)) (values (cons 'intset-from-ranges element-codes) (make-set-type world element-type) (list* 'expr-annotation:special-form special-form element-type-expr element-annotated-exprs))))) ;;; Tags (defparameter *tag-counter* 0) ; (tag ... ) (defun scan-tag-expr (world type-env special-form tag-name &rest value-exprs) (let* ((tag (scan-tag world tag-name)) (type (make-tag-type world tag)) (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 value-expr) (scan-typed-value world type-env value-expr (field-type field))) (fields value-exprs) (values (or (tag-keyword tag) (let ((name (tag-name tag))) (if (tag-mutable tag) (list* 'list (list 'quote name) '(incf *tag-counter*) value-codes) (list* 'list (list 'quote name) value-codes)))) type (list* 'expr-annotation:special-form special-form tag value-annotated-exprs))))) ; (&