X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=acec94124d3c945b778b9e51c0888adedc20f83a;hb=1394636aef3b85be4fb6ef4a5424115aa2022d99;hp=e809bb3f508ebbaadf60f148e49bdad4d76fa775;hpb=a8f0175b16a00f5fc83eb8d8a718ae7fc5497514;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index e809bb3..acec941 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -12,7 +12,7 @@
 
 (in-package "SB!C")
 
-;;;; control special forms
+;;;; special forms for control
 
 (def-ir1-translator progn ((&rest forms) start cont)
   #!+sb-doc
@@ -84,7 +84,6 @@
       (push env-entry (continuation-lexenv-uses cont))
       (ir1-convert-progn-body dummy cont forms))))
 
-
 (def-ir1-translator return-from ((name &optional value) start cont)
   #!+sb-doc
   "Return-From Block-Name Value-Form
@@ -356,39 +355,32 @@
 ;;; VOP or %VOP.. -- WHN 2001-06-11
 ;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
 (def-ir1-translator %primitive ((name &rest args) start cont)
-  (unless (symbolp name)
-    (compiler-error "internal error: Primitive name ~S is not a symbol." name))
+  (declare (type symbol name))
   (let* ((template (or (gethash name *backend-template-names*)
-		       (compiler-error
-			"internal error: Primitive name ~A is not defined."
-			name)))
+		       (bug "undefined primitive ~A" name)))
 	 (required (length (template-arg-types template)))
 	 (info (template-info-arg-count template))
 	 (min (+ required info))
 	 (nargs (length args)))
     (if (template-more-args-type template)
 	(when (< nargs min)
-	  (compiler-error "internal error: Primitive ~A was called ~
-                           with ~R argument~:P, ~
-	    		   but wants at least ~R."
-			  name
-			  nargs
-			  min))
+	  (bug "Primitive ~A was called with ~R argument~:P, ~
+	    	but wants at least ~R."
+	       name
+	       nargs
+	       min))
 	(unless (= nargs min)
-	  (compiler-error "internal error: Primitive ~A was called ~
-                           with ~R argument~:P, ~
-			   but wants exactly ~R."
-			  name
-			  nargs
-			  min)))
+	  (bug "Primitive ~A was called with ~R argument~:P, ~
+                but wants exactly ~R."
+	       name
+	       nargs
+	       min)))
 
     (when (eq (template-result-types template) :conditional)
-      (compiler-error
-       "%PRIMITIVE was used with a conditional template."))
+      (bug "%PRIMITIVE was used with a conditional template."))
 
     (when (template-more-results-type template)
-      (compiler-error
-       "%PRIMITIVE was used with an unknown values template."))
+      (bug "%PRIMITIVE was used with an unknown values template."))
 
     (ir1-convert start
 		 cont
@@ -509,14 +501,14 @@
 ;;;; any pervasive declarations also affect the evaluation of the
 ;;;; arguments.)
 
-;;; Given a list of binding specifiers in the style of Let, return:
+;;; Given a list of binding specifiers in the style of LET, return:
 ;;;  1. The list of var structures for the variables bound.
 ;;;  2. The initial value form for each variable.
 ;;;
 ;;; The variable names are checked for legality and globally special
 ;;; variables are marked as such. Context is the name of the form, for
 ;;; error reporting purposes.
-(declaim (ftype (function (list symbol) (values list list list))
+(declaim (ftype (function (list symbol) (values list list))
 		extract-let-vars))
 (defun extract-let-vars (bindings context)
   (collect ((vars)
@@ -531,7 +523,7 @@
 	(cond ((atom spec)
 	       (let ((var (get-var spec)))
 		 (vars var)
-		 (names (cons spec var))
+		 (names spec)
 		 (vals nil)))
 	      (t
 	       (unless (proper-list-of-length-p spec 1 2)
@@ -544,7 +536,7 @@
 		 (names name)
 		 (vals (second spec)))))))
 
-    (values (vars) (vals) (names))))
+    (values (vars) (vals))))
 
 (def-ir1-translator let ((bindings &body body)
 			 start cont)
@@ -555,12 +547,13 @@
   evaluated."
   (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
     (multiple-value-bind (vars values) (extract-let-vars bindings 'let)
-      (let* ((*lexenv* (process-decls decls vars nil cont))
-	     (fun-cont (make-continuation))
-	     (fun (ir1-convert-lambda-body
-		   forms vars :debug-name (debug-namify "LET ~S" bindings))))
-	(reference-leaf start fun-cont fun)
-	(ir1-convert-combination-args fun-cont cont values)))))
+      (let ((fun-cont (make-continuation)))
+        (let* ((*lexenv* (process-decls decls vars nil cont))
+               (fun (ir1-convert-lambda-body
+                     forms vars
+                     :debug-name (debug-namify "LET ~S" bindings))))
+          (reference-leaf start fun-cont fun))
+        (ir1-convert-combination-args fun-cont cont values)))))
 
 (def-ir1-translator let* ((bindings &body body)
 			  start cont)