From 7c92b0fc8c811a3427a186292bfbf5cc2308a2fa Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Thu, 13 May 2010 17:03:28 +0200 Subject: [PATCH] The function C1FORM-VALUES-NUMBER is now factored and grouped with the other C1FORM functions in cmpform. --- src/cmp/cmpform.lsp | 30 ++++++++++++++++++++++++------ src/cmp/cmpmulti.lsp | 12 ------------ src/cmp/cmptype-arith.lsp | 11 +++++++++++ 3 files changed, 35 insertions(+), 18 deletions(-) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp index 2000e39e1..c527a2008 100644 --- a/src/cmp/cmpform.lsp +++ b/src/cmp/cmpform.lsp @@ -26,8 +26,8 @@ (eval-when (:compile-toplevel :execute) (defconstant +all-c1-forms+ - '((LOCATION loc :pure) - (VAR var) + '((LOCATION loc :pure :single-valued) + (VAR var :single-valued) (SETQ var value-c1form :side-effects) (PSETQ var-list value-c1form-list :side-effects) (BLOCK blk-var progn-c1form :pure) @@ -60,7 +60,7 @@ (MULTIPLE-VALUE-SETQ vars-list values-c1form-list :side-effects) (MULTIPLE-VALUE-BIND vars-list init-c1form body :pure) (COMPILER-LET symbols values body) - (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object) + (FUNCTION (GLOBAL/CLOSURE) lambda-form fun-object :single-valued) (C2PRINC object-string-or-char stream-var stream-c1form :side-effects) (RPLACA (dest-c1form value-c1form) :side-effects) (RPLACD (dest-c1form value-c1form) :side-effects) @@ -74,7 +74,7 @@ (STACK-PUSH-VALUES value-c1form push-statement-c1form :side-effects) (ORDINARY c1form :pure) - (LOAD-TIME-VALUE dest-loc value-c1form :pure) + (LOAD-TIME-VALUE dest-loc value-c1form :pure :single-valued) (SI:FSET function-object vv-loc macro-p pprint-p lambda-form :side-effects) (MAKE-FORM vv-loc value-c1form :side-effects) @@ -90,7 +90,10 @@ for movable = (if (member :pure rest) (progn (and length (decf length)) t) nil) - do (setf (gethash name hash) (list length side-effects movable)) + for single-valued = (if (member :single-valued rest) + (progn (and length (decf length)) t) + nil) + do (setf (gethash name hash) (list length side-effects movable single-valued)) finally (return hash))) (defun print-c1form (form stream) @@ -181,7 +184,7 @@ (c1form-sp-change dest) (c1form-sp-change new-fields) (c1form-side-effects dest) (c1form-side-effects new-fields) (c1form-volatile dest) (c1form-volatile new-fields) - (c1form-name dest) 'VALUES + (c1form-name dest) 'PROGN (c1form-args dest) (list (list new-fields)))) (defun copy-c1form (form) @@ -246,3 +249,18 @@ (return-from c1form-unmodified-p nil)))))) (traverse-c1form-tree form #'abort-on-not-pure) t)) + +(defun c1form-values-number (form) + (if (fourth (gethash (c1form-name form) +c1-form-hash+)) + (values 1 1) + (values-number-from-type (c1form-type form)))) + +#+(or) +(defun c1form-single-valued-p (form) + (or (fourth (gethash (c1form-name form) +c1-form-hash+)) + (<= (nth-value 1 (c1form-values-number form))))) + +#+(or) +(defun c1form-values-number (form) + (values-number-from-type (c1form-type form))) + diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 47969754c..badbc0b20 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -144,18 +144,6 @@ (add-to-set-nodes-of-var-list vars (make-c1form* 'MULTIPLE-VALUE-SETQ :args vars value)))))) -(defun c1form-values-number (form) - (let ((type (c1form-type form))) - (cond ((or (eq type 'T) (eq type '*)) - (values 0 MULTIPLE-VALUES-LIMIT)) - ((or (atom type) (not (eq (first type) 'VALUES))) - (values 1 1)) - ((or (member '&rest type) (member 'optional type)) - (values 0 MULTIPLE-VALUES-LIMIT)) - (t - (let ((l (1- (length type)))) - (values l l)))))) - (defun do-m-v-setq-fixed (nvalues vars form use-bind &aux (output (first vars))) ;; This routine should evaluate FORM and store the values (whose amount ;; is known to be NVALUES) into the variables VARS. The output is a diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 2f4ead372..615b84084 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -112,6 +112,17 @@ (cmpnote "Unknown type ~S. Assuming it is T." t2) t1)))) +(defun values-number-from-type (type) + (cond ((or (eq type 'T) (eq type '*)) + (values 0 MULTIPLE-VALUES-LIMIT)) + ((or (atom type) (not (eq (first type) 'VALUES))) + (values 1 1)) + ((or (member '&rest type) (member 'optional type)) + (values 0 MULTIPLE-VALUES-LIMIT)) + (t + (let ((l (1- (length type)))) + (values l l))))) + (defun-equal-cached values-type-primary-type (type) (when (and (consp type) (eq (first type) 'VALUES)) (let ((subtype (second type)))