From 846a2fd99ffcd1829dc3bd950ac9f95fb4af984b Mon Sep 17 00:00:00 2001 From: "waldemar%netscape.com" Date: Thu, 1 Mar 2001 05:35:44 +0000 Subject: [PATCH] Renamed double to float64, added progn, and added support for ? within rules --- js2/semantics/Calculus.lisp | 241 ++++++++++++++++++++++-------------- 1 file changed, 150 insertions(+), 91 deletions(-) diff --git a/js2/semantics/Calculus.lisp b/js2/semantics/Calculus.lisp index e88ec7d308d..a0d8dfe8b96 100644 --- a/js2/semantics/Calculus.lisp +++ b/js2/semantics/Calculus.lisp @@ -77,10 +77,10 @@ ;;; ------------------------------------------------------------------------------------------------------ ;;; DOUBLE-PRECISION FLOATING-POINT NUMBERS -(deftype double () +(deftype float64 () '(or float (member :+inf :-inf :nan))) -(defun double? (n) +(defun float64? (n) (or (floatp n) (member n '(:+inf :-inf :nan)))) @@ -92,25 +92,25 @@ (floating-point-overflow () (if (minusp (progn ,@sign)) :-inf :+inf)))) -(defun rational-to-double (r) +(defun rational-to-float64 (r) (handle-overflow (coerce r 'double-float) r)) ; Return true if n is +0 or -0 and false otherwise. -(declaim (inline double-is-zero)) -(defun double-is-zero (n) +(declaim (inline float64-is-zero)) +(defun float64-is-zero (n) (and (floatp n) (zerop n))) ; Return true if n is NaN and false otherwise. -(declaim (inline double-is-nan)) -(defun double-is-nan (n) +(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 double-is-infinite)) -(defun double-is-infinite (n) +(declaim (inline float64-is-infinite)) +(defun float64-is-infinite (n) (or (eq n :+inf) (eq n :-inf))) @@ -119,9 +119,9 @@ ; equal if n=m; ; greater if n>m; ; unordered if either n or m is :nan. -(defun double-compare (n m less equal greater unordered) +(defun float64-compare (n m less equal greater unordered) (cond - ((or (double-is-nan n) (double-is-nan m)) unordered) + ((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) @@ -134,7 +134,7 @@ ; 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 double-sign (n) +(defun float64-sign (n) (case n (:+inf 1) (:-inf -1) @@ -142,16 +142,26 @@ (t (round (float-sign n))))) +(assert-true (and (= (float64-sign 0.0) 1) (= (float64-sign -0.0) -1))) + + ; Return ; 0 if either n or m is :nan; -; 1 if n and m have the same double-sign; -; -1 if n and m have different double-signs. -(defun double-sign-xor (n m) - (* (double-sign n) (double-sign m))) +; 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 + ((:+inf :-inf :nan) 0) + (t (mod (truncate d) #x100000000)))) ; Return the absolute value of n. -(defun double-abs (n) +(defun float64-abs (n) (case n ((:+inf :-inf) :+inf) (:nan :nan) @@ -159,7 +169,7 @@ ; Return -n. -(defun double-neg (n) +(defun float64-neg (n) (case n (:+inf :-inf) (:-inf :+inf) @@ -168,7 +178,7 @@ ; Return n+m. -(defun double-add (n m) +(defun float64-add (n m) (case n (:+inf (case m (:-inf :nan) @@ -191,30 +201,30 @@ ; Return n-m. -(defun double-subtract (n m) - (double-add n (double-neg m))) +(defun float64-subtract (n m) + (float64-add n (float64-neg m))) ; Return n*m. -(defun double-multiply (n m) - (let ((sign (double-sign-xor n m)) - (n (double-abs n)) - (m (double-abs 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 (double-is-zero m) :nan :+inf)) - ((eq m :+inf) (if (double-is-zero n) :nan :+inf)) + ((eq n :+inf) (if (float64-is-zero m) :nan :+inf)) + ((eq m :+inf) (if (float64-is-zero n) :nan :+inf)) (t (handle-overflow (* n m) 1))))) (if (minusp sign) - (double-neg result) + (float64-neg result) result)))) ; Return n/m. -(defun double-divide (n m) - (let ((sign (double-sign-xor n m)) - (n (double-abs n)) - (m (double-abs 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)) @@ -222,25 +232,18 @@ ((zerop m) (if (zerop n) :nan :+inf)) (t (handle-overflow (/ n m) 1))))) (if (minusp sign) - (double-neg result) + (float64-neg result) result)))) ; Return n%m, using the ECMAScript definition of %. -(defun double-remainder (n m) +(defun float64-remainder (n m) (cond - ((or (double-is-nan n) (double-is-nan m) (double-is-infinite n) (double-is-zero m)) :nan) - ((or (double-is-infinite m) (double-is-zero n)) n) + ((or (float64-is-nan n) (float64-is-nan m) (float64-is-infinite n) (float64-is-zero m)) :nan) + ((or (float64-is-infinite m) (float64-is-zero n)) n) (t (float (rem (rational n) (rational m)))))) -; Return d truncated towards zero into a 32-bit integer. Overflows wrap around. -(defun double-to-uint32 (d) - (case d - ((:+inf :-inf :nan) 0) - (t (mod (truncate d) #x100000000)))) - - ;;; ------------------------------------------------------------------------------------------------------ ;;; SET UTILITIES @@ -519,7 +522,7 @@ (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 - (double-type nil :type (or null type)) ;Type used for double-precision floating-point numbers + (float64-type nil :type (or null type)) ;Type used for double-precision floating-point numbers (id-type nil :type (or null type)) ;Type used for id's (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) @@ -807,7 +810,7 @@ :boolean ;nil ;nil :integer ;nil ;nil :rational ;nil ;nil - :double ;nil ;nil + :float64 ;nil ;nil :id ;nil ;nil :character ;nil ;nil :-> ;nil ;(result-type arg1-type arg2-type ... argn-type) @@ -949,7 +952,7 @@ (:boolean (write-string "boolean" stream)) (:integer (write-string "integer" stream)) (:rational (write-string "rational" stream)) - (:double (write-string "double" stream)) + (:float64 (write-string "float64" stream)) (:id (write-string "id" stream)) (:character (write-string "character" stream)) (:-> (pprint-logical-block (stream nil :prefix "(" :suffix ")") @@ -1505,7 +1508,7 @@ (:boolean t) (:integer (integerp value)) (:rational (rationalp value)) - (:double (double? value)) + (:float64 (float64? value)) (:id (and value (symbolp value))) (:character (characterp value)) (:-> (functionp value)) @@ -1546,11 +1549,11 @@ (write-string "empty" stream)) (:boolean (write-string (if value "true" "false") stream)) ((:integer :rational :id :character :->) (write value :stream stream)) - (:double (case value - (:+inf (write-string "+infinity" stream)) - (:-inf (write-string "-infinity" stream)) - (:nan (write-string "NaN" stream)) - (t (write value :stream stream)))) + (:float64 (case value + (:+inf (write-string "+infinity" stream)) + (:-inf (write-string "-infinity" stream)) + (:nan (write-string "NaN" stream)) + (t (write value :stream stream)))) (:vector (let ((element-type (vector-element-type type))) (if (eq (type-kind element-type) :character) (prin1 value stream) @@ -1745,7 +1748,7 @@ ((consp value-expr) (scan-cons (first value-expr) (rest value-expr))) ((identifier? value-expr) (scan-identifier (world-intern world value-expr))) ((integerp value-expr) (scan-constant value-expr (world-integer-type world))) - ((floatp value-expr) (scan-constant value-expr (world-double-type world))) + ((floatp value-expr) (scan-constant value-expr (world-float64-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)))))) @@ -1994,6 +1997,25 @@ (list 'expr-annotation:special-form special-form condition-annotated-expr true-annotated-expr false-annotated-expr))))))) +; (progn ... ) +(defun scan-progn (world type-env special-form expr1 expr2 &rest more-exprs) + (let* ((exprs (list* expr1 expr2 more-exprs)) + (last-expr (car (last exprs))) + (void-exprs (butlast exprs)) + (codes nil) + (annotated-exprs nil)) + (dolist (void-expr void-exprs) + (multiple-value-bind (void-code void-annotated-expr) + (scan-typed-value world type-env void-expr (world-void-type world)) + (push void-code codes) + (push void-annotated-expr annotated-exprs))) + (multiple-value-bind (last-code last-type last-annotated-expr) (scan-value world type-env last-expr) + (values + (cons 'progn (nreconc codes (list last-code))) + last-type + (list* 'expr-annotation:special-form special-form (nreconc annotated-exprs (list last-annotated-expr))))))) + + (defconstant *semantic-exception-type-name* 'semantic-exception) ; (throw ) @@ -2656,6 +2678,7 @@ (todo scan-bottom depict-bottom) (function scan-function depict-function) (if scan-if depict-if) + (progn scan-progn depict-progn) (throw scan-throw depict-throw) (catch scan-catch depict-catch) @@ -2705,7 +2728,7 @@ (boolean . :boolean) (integer . :integer) (rational . :rational) - (double . :double) + (float64 . :float64) (id . :id) (character . :character))) @@ -2714,14 +2737,15 @@ '((empty void nil :global :empty-10 %primary%) (true boolean t :global :true %primary%) (false boolean nil :global :false %primary%) - (+infinity double :+inf :global ("+" :infinity) %prefix%) - (-infinity double :-inf :global (:minus :infinity) %prefix%) - (nan double :nan :global "NaN" %primary%) + (+infinity float64 :+inf :global ("+" :infinity) %prefix%) + (-infinity float64 :-inf :global (:minus :infinity) %prefix%) + (nan float64 :nan :global "NaN" %primary%) (neg (-> (integer) integer) #'- :unary :minus nil %suffix% %suffix%) + (* (-> (integer integer) integer) #'* :infix "*" nil %factor% %factor% %factor%) + (mod (-> (integer integer) integer) #'mod :infix ((:semantic-keyword "mod")) nil %factor% %factor% %unary%) (+ (-> (integer integer) integer) #'+ :infix "+" t %term% %term% %term%) (- (-> (integer integer) integer) #'- :infix :minus t %term% %term% %factor%) - (* (-> (integer integer) integer) #'* :infix "*" nil %factor% %factor% %factor%) (= (-> (integer integer) boolean) #'= :infix "=" t %relational% %term% %term%) (/= (-> (integer integer) boolean) #'/= :infix :not-equal t %relational% %term% %term%) (< (-> (integer integer) boolean) #'< :infix "<" t %relational% %term% %term%) @@ -2730,10 +2754,10 @@ (>= (-> (integer integer) boolean) #'>= :infix :greater-or-equal t %relational% %term% %term%) (rational-neg (-> (rational) rational) #'- :unary "-" nil %suffix% %suffix%) - (rational+ (-> (rational rational) rational) #'+ :infix "+" t %term% %term% %term%) - (rational- (-> (rational rational) rational) #'- :infix :minus t %term% %term% %factor%) (rational* (-> (rational rational) rational) #'* :infix "*" nil %factor% %factor% %factor%) (rational/ (-> (rational rational) rational) #'/ :infix "/" nil %factor% %factor% %unary%) + (rational+ (-> (rational rational) rational) #'+ :infix "+" t %term% %term% %term%) + (rational- (-> (rational rational) rational) #'- :infix :minus t %term% %term% %factor%) (not (-> (boolean) boolean) #'not :unary ((:semantic-keyword "not") " ") nil %not% %not%) (and (-> (boolean boolean) boolean) #'and2 :infix ((:semantic-keyword "and")) t %and% %and% %and%) @@ -2745,19 +2769,21 @@ (bitwise-xor (-> (integer integer) integer) #'logxor) (bitwise-shift (-> (integer integer) integer) #'ash) - (rational-to-double (-> (rational) double) #'rational-to-double) + (rational-to-float64 (-> (rational) float64) #'rational-to-float64) + (float64-to-rational (-> (float64) rational) #'rational) + (truncate-float64 (-> (float64) integer) #'truncate) - (double-is-zero (-> (double) boolean) #'double-is-zero) - (double-is-nan (-> (double) boolean) #'double-is-nan) - (double-compare (-> (double double boolean boolean boolean boolean) boolean) #'double-compare) - (double-to-uint32 (-> (double) integer) #'double-to-uint32) - (double-abs (-> (double double) double) #'double-abs) - (double-negate (-> (double) double) #'double-neg) - (double-add (-> (double double) double) #'double-add) - (double-subtract (-> (double double) double) #'double-subtract) - (double-multiply (-> (double double) double) #'double-multiply) - (double-divide (-> (double double) double) #'double-divide) - (double-remainder (-> (double double) double) #'double-remainder) + (float64-is-zero (-> (float64) boolean) #'float64-is-zero) + (float64-is-na-n (-> (float64) boolean) #'float64-is-nan) + (float64-is-infinite (-> (float64) boolean) #'float64-is-infinite) + (float64-compare (-> (float64 float64 boolean boolean boolean boolean) boolean) #'float64-compare) + (float64-abs (-> (float64 float64) float64) #'float64-abs) + (float64-negate (-> (float64) float64) #'float64-neg) + (float64-add (-> (float64 float64) float64) #'float64-add) + (float64-subtract (-> (float64 float64) float64) #'float64-subtract) + (float64-multiply (-> (float64 float64) float64) #'float64-multiply) + (float64-divide (-> (float64 float64) float64) #'float64-divide) + (float64-remainder (-> (float64 float64) float64) #'float64-remainder) (unique id (gensym "U") :global :unique %primary%) (id= (-> (id id) boolean) #'eq :infix "=" t %relational% %term% %term%) @@ -2816,7 +2842,8 @@ (def-partial-order-element *primitive-level* %unparenthesized-new% %logical%) ;new v (defparameter %expr% %unparenthesized-new%) (def-partial-order-element *primitive-level* %stmt% %expr%) ;:=, function, if/then/else -(defparameter %max% %stmt%) +(def-partial-order-element *primitive-level* %progn% %stmt%) ;progn +(defparameter %max% %progn%) ; Return the tail end of the lambda list for make-primitive. The returned list always starts with @@ -3098,7 +3125,7 @@ (setf (world-boolean-type world) (make-type world :boolean nil nil)) (setf (world-integer-type world) (make-type world :integer nil nil)) (setf (world-rational-type world) (make-type world :rational nil nil)) - (setf (world-double-type world) (make-type world :double nil nil)) + (setf (world-float64-type world) (make-type world :float64 nil nil)) (setf (world-id-type world) (make-type world :id nil nil)) (setf (world-character-type world) (make-type world :character nil nil)) (setf (world-string-type world) (make-vector-type world (world-character-type world))) @@ -3264,6 +3291,25 @@ nil))))) +; commands is a list of commands and/or (? ...), where the ... is a list of commands. +; Call f on each non-deleted command, passing it that command and the current value of highlight. +; f returns a list of preprocessed commands; return the destructive concatenation of these lists. +(defun each-preprocessed-command (f preprocessor-state commands highlight) + (mapcan + #'(lambda (command) + (if (and (consp command) (eq (car command) '?)) + (progn + (assert-type command (cons t cons t (list t))) + (let* ((commands (cddr command)) + (new-highlight (resolve-conditional (preprocessor-state-world preprocessor-state) (second command)))) + (cond + ((eq new-highlight 'delete)) + ((eq new-highlight highlight) (each-preprocessed-command f preprocessor-state commands new-highlight)) + (t (list (list* '? (second command) (each-preprocessed-command f preprocessor-state commands new-highlight))))))) + (funcall f command highlight))) + commands)) + + ; (define ) ; ==> ; (define nil) @@ -3431,6 +3477,8 @@ ; (action ) ; ... ; (action ) +; +; The productions may be enclosed by (? ...) preprocessor actions. (defun preprocess-rule (preprocessor-state command general-grammar-symbol action-declarations &rest productions) (declare (ignore command)) (assert-type action-declarations (list (tuple symbol t))) @@ -3445,25 +3493,37 @@ (and (eq declared-action-name action-name) (actions-match (rest action-declarations) (rest actions))))))) - (let ((commands-reverse nil)) - (dolist (production productions) - (assert-true (eq (first production) 'production)) - (let ((lhs (second production)) - (rhs (third production)) - (name (assert-type (fourth production) symbol)) - (actions (assert-type (cddddr production) (list (tuple t t))))) - (unless (actions-match action-declarations actions) - (error "Action name mismatch: ~S vs. ~S" action-declarations actions)) - (push (list lhs rhs name (preprocessor-state-highlight preprocessor-state)) - (preprocessor-state-grammar-source-reverse preprocessor-state)) - (push (list '%rule lhs) commands-reverse))) + (let ((commands-reverse + (nreverse + (each-preprocessed-command + #'(lambda (production highlight) + (assert-true (eq (first production) 'production)) + (let ((lhs (second production)) + (rhs (third production)) + (name (assert-type (fourth production) symbol)) + (actions (assert-type (cddddr production) (list (tuple t t))))) + (unless (actions-match action-declarations actions) + (error "Action name mismatch: ~S vs. ~S" action-declarations actions)) + (push (list lhs rhs name highlight) (preprocessor-state-grammar-source-reverse preprocessor-state)) + (list (list '%rule lhs)))) + preprocessor-state + productions + (preprocessor-state-highlight preprocessor-state))))) (dotimes (i (length action-declarations)) (let ((action-declaration (nth i action-declarations))) (push (list 'declare-action (first action-declaration) general-grammar-symbol (second action-declaration)) commands-reverse) - (dolist (production productions) - (let ((name (fourth production)) - (action (nth (+ i 4) production))) - (push (list 'action (first action) name (second action)) commands-reverse))))) + (setq commands-reverse + (nreconc + (each-preprocessed-command + #'(lambda (production highlight) + (declare (ignore highlight)) + (let ((name (fourth production)) + (action (nth (+ i 4) production))) + (list (list 'action (first action) name (second action))))) + preprocessor-state + productions + (preprocessor-state-highlight preprocessor-state)) + commands-reverse)))) (values (nreverse commands-reverse) t)))) @@ -3477,4 +3537,3 @@ (setf (preprocessor-state-excluded-nonterminals-source preprocessor-state) (append excluded-nonterminals-source (preprocessor-state-excluded-nonterminals-source preprocessor-state))) (values nil nil)) -