(VALUES form) now truncates the number of values output by 'form' to one.

src/cmp/cmpinline.lsp

@@ -353,15 +353,3 @@
 
 (defun args-cause-side-effect (forms)
   (some #'form-causes-side-effect forms))
-
-;;; ----------------------------------------------------------------------
-
-(put-sysprop 'FIXNUM 'WT-LOC 'wt-fixnum-loc)
-(put-sysprop 'CHARACTER 'WT-LOC 'wt-character-loc)
-(put-sysprop 'LONG-FLOAT 'WT-LOC 'wt-long-float-loc)
-(put-sysprop 'SHORT-FLOAT 'WT-LOC 'wt-short-float-loc)
-(put-sysprop 'BOOLEAN 'WT-LOC 'wt-loc)
-(put-sysprop 'T 'WT-LOC 'wt-loc)
-;;; Since they are possible locations, we must add:
-(put-sysprop 'STRING 'WT-LOC 'wt-loc)
-(put-sysprop 'BIT-VECTOR 'WT-LOC 'wt-loc)

src/cmp/cmploc.lsp

@@ -16,43 +16,45 @@
 ;;;	NIL
 ;;;	T
 ;;;	fixnum
-;;;	'VALUES'
+;;;	VALUE0
+;;;	VALUES
 ;;;	var-object
-;;;	( 'VALUE' i )			VALUES(i)
-;;;	( 'VV' vv-index )
-;;;	( 'LCL' lcl )			local variable, type unboxed
-;;;	( 'TEMP' temp )			local variable, type object
-;;;	( 'CALL' fun narg locs fname )	locs are locations containing the arguments
-;;;	( 'CALL-LOCAL' fun lex closure args narg fname )
-;;;	( 'C-INLINE' output-type fun/string locs side-effects output-var )
-;;;	( 'CAR' lcl )
-;;;	( 'CADR' lcl )
-;;;	( 'FDEFINITION' vv-index )
-;;;	( 'MAKE-CCLOSURE' cfun )
-;;;	( 'FIXNUM-VALUE' fixnum-value )
-;;;	( 'CHARACTER-VALUE' character-code )
-;;;	( 'LONG-FLOAT-VALUE' long-float-value vv )
-;;;	( 'SHORT-FLOAT-VALUE' short-float-value vv )
-;;;	'VA-ARG'
-;;;	'CL-VA-ARG'
+;;;	( VALUE i )			VALUES(i)
+;;;	( VV vv-index )
+;;;	( LCL lcl )			local variable, type unboxed
+;;;	( TEMP temp )			local variable, type object
+;;;	( CALL fun narg locs fname )	locs are locations containing the arguments
+;;;	( CALL-FIX fun locs fname)	similar as CALL, but number of arguments is fixed
+;;;	( CALL-LOCAL fun lex closure args narg fname )
+;;;	( C-INLINE output-type fun/string locs side-effects output-var )
+;;;	( COERCE-LOC representation-type location)
+;;;	( CAR lcl )
+;;;	( CDR lcl )
+;;;	( CADR lcl )
+;;;	( FDEFINITION vv-index )
+;;;	( MAKE-CCLOSURE cfun )
+;;;	( FIXNUM-VALUE fixnum-value )
+;;;	( CHARACTER-VALUE character-code )
+;;;	( LONG-FLOAT-VALUE long-float-value vv )
+;;;	( SHORT-FLOAT-VALUE short-float-value vv )
+;;;	( STACK-POINTER index )	retrieve a value from the stack
+;;;	( SYS:STRUCTURE-REF loc slot-name-vv slot-index )
+;;;	( KEYVARS n )
+;;;	VA-ARG
+;;;	CL-VA-ARG
 
 ;;; Valid *DESTINATION* locations are:
 ;;;
-;;;	'RETURN'	The value is returned from the current function.
-;;;	'RETURN-FIXNUM'
-;;;	'RETURN-CHARACTER'
-;;;	'RETURN-LONG-FLOAT'
-;;;	'RETURN-SHORT-FLOAT'
-;;;	'RETURN-OBJECT
-;;;	'TRASH'			The value may be thrown away.
-;;;	'VALUES'
+;;;	VALUE0
+;;;	RETURN				Object returned from current function.
+;;;	TRASH				Value may be thrown away.
+;;;	VALUES				Values vector.
 ;;;	var-object
-;;;	( 'LCL' lcl )
-;;;	( 'LEX' lex-address )
-;;;	( 'BIND' var alternative )	; alternative is optional
-;;;	( 'JUMP-TRUE' label )
-;;;	( 'JUMP-FALSE' label )
-;;;	( 'PUSH-CATCH-FRAME' )
+;;;	( LCL lcl )
+;;;	( LEX lex-address )
+;;;	( BIND var alternative )	Alternative is optional
+;;;	( JUMP-TRUE label )
+;;;	( JUMP-FALSE label )
 
 (defun set-loc (loc &aux fd
 		    (is-call (and (consp loc)
@@ -65,9 +67,12 @@
 	   ((eq loc 'VALUES) (return-from set-loc))
 	   (t
 	    (wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;"))))
+    (VALUE0
+     (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";"))
     (RETURN
      (cond ((or is-call (eq loc 'VALUES))
 	    (wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";"))
+	   ((eq loc 'VALUE0) (wt-nl "NVALUES=1;"))
 	   ((eq loc 'RETURN) (return-from set-loc))
 	   (t
 	    (wt-nl "value0=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;"))))
@@ -103,6 +108,8 @@
 	 (wt "va_arg(args,cl_object)"))
 	((eq loc 'CL-VA-ARG)
 	 (wt "cl_va_arg(args)"))
+	((eq loc 'VALUE0)
+	 (wt "value0"))
 	((var-p loc)
 	 (wt-var loc))
         ((or (not (consp loc))

src/cmp/cmpmulti.lsp

@@ -12,13 +12,19 @@
 
 (in-package "COMPILER")
 
-(defun c1multiple-value-call (args)
+(defun c1multiple-value-call (args &aux forms)
   (check-args-number 'MULTIPLE-VALUE-CALL args 1)
-  (cond ((endp (rest args)) (c1funcall args))
-	;; FIXME! We should optimize
-	;; (multiple-value-call ... (values a b c ...))
-        (t (let ((funob (c1expr (first args))))
-	     (make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args)))))))
+  (cond
+   ;; (M-V-C #'FUNCTION) => (FUNCALL #'FUNCTION)
+   ((endp (rest args)) (c1funcall args))
+   ;; (M-V-C #'FUNCTION (VALUES A ... Z)) => (FUNCALL #'FUNCTION A ... Z)
+   ((and (= (length args) 2)
+	 (consp (setq forms (second args)))
+	 (eq 'VALUES (first forms)))
+    (c1funcall (list* (first args) (rest forms))))
+   ;; More complicated case.
+   (t (let ((funob (c1expr (first args))))
+	(make-c1form 'MULTIPLE-VALUE-CALL funob funob (c1args* (rest args)))))))
 
 (defun c2multiple-value-call (funob forms)
   (let* ((tot (make-lcl-var :rep-type :cl-index))
@@ -60,10 +66,7 @@
 ;;; if this occurred in a proclaimed fun.
 
 (defun c1values (args)
-  (if (and args (null (rest args)))
-    ;; unnecessary code is produced for expression (values nil)
-    (c1expr (first args))
-    (make-c1form* 'VALUES :args (c1args* args))))
+  (make-c1form* 'VALUES :args (c1args* args)))
 
 (defun c2values (forms)
   (when (and (eq *destination* 'RETURN-OBJECT)
@@ -74,24 +77,45 @@
               ~%;But ~a was proclaimed to have single value.~
               ~%;Only first one will be assured."
              (second *current-form*)))
-  (let ((nv (length forms)))
-    (declare (fixnum nv))
-    (case nv
-      (0 (wt-nl "value0=Cnil;NVALUES=0;")
-	 (unwind-exit 'RETURN))
-      (1 (c2expr (first forms)))
-      (t (let* ((*inline-blocks* 0)
-		(forms (nreverse (coerce-locs (inline-args forms)))))
-	   ;; 1) By inlining arguments we make sure that VL has no call to funct.
-	   ;; 2) Reverse args to avoid clobbering VALUES(0)
-	   (wt-nl "NVALUES=" nv ";")
-	   (do ((vl forms (rest vl))
-		(i (1- (length forms)) (1- i)))
-	       ((null vl))
-	     (declare (fixnum i))
-	     (wt-nl "VALUES(" i ")=" (first vl) ";"))
-	   (unwind-exit 'VALUES)
-	   (close-inline-blocks))))))
+  (cond
+   ;; When the values are not going to be used, then just
+   ;; process each form separately.
+   ((eq *destination* 'TRASH)
+    (mapc #'c2expr forms))
+   ;; For (VALUES) we can replace the output with either NIL (if the value
+   ;; is actually used) and set only NVALUES when the value is the output
+   ;; of a function.
+   ((endp forms)
+    (cond ((eq *destination* 'RETURN)
+	   (wt-nl "value0=Cnil; NVALUES=0;")
+	   (unwind-exit 'RETURN))
+	  ((eq *destination* 'VALUES)
+	   (wt-nl "VALUES(0)=Cnil; NVALUES=0;")
+	   (unwind-exit 'VALUES))
+	  (t
+	   (unwind-exit 'NIL))))
+   ;; For a single form, we must simply ensure that we only take a single
+   ;; value of those that the function may output.
+   ((endp (rest forms))
+    (let ((*destination* 'VALUE0))
+      (c2expr* (first forms)))
+    (unwind-exit 'VALUE0))
+   ;; In all other cases, we store the values in the VALUES vector,
+   ;; and force the compiler to retrieve anything out of it.
+   (t
+    (let* ((nv (length forms))
+	   (*inline-blocks* 0)
+	   (forms (nreverse (coerce-locs (inline-args forms)))))
+      ;; By inlining arguments we make sure that VL has no call to funct.
+      ;; Reverse args to avoid clobbering VALUES(0)
+      (wt-nl "NVALUES=" nv ";")
+      (do ((vl forms (rest vl))
+	   (i (1- (length forms)) (1- i)))
+	  ((null vl))
+	(declare (fixnum i))
+	(wt-nl "VALUES(" i ")=" (first vl) ";"))
+      (unwind-exit 'VALUES)
+      (close-inline-blocks)))))
 
 (defun c1multiple-value-setq (args &aux (info (make-info)) (vrefs nil)
 			      (vars nil) (temp-vars nil) (late-bindings nil))