Index: /branches/arm/compiler/ARM/arm-arch.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-arch.lisp	(revision 13704)
+++ /branches/arm/compiler/ARM/arm-arch.lisp	(revision 13705)
@@ -26,21 +26,40 @@
 
 
-
-(defvar *arm-gprs* (make-hash-table :test #'equalp))
+(defvar *standard-arm-register-names* ())
+(defvar *arm-register-names* ())
+
+
+(defun get-arm-register (name)
+  (let* ((pair (assoc (string name) *arm-register-names* :test #'string-equal)))
+    (if pair
+      (cdr pair))))
 
 (defun get-arm-gpr (name)
-  (values (gethash (string name)  *arm-gprs*)))
-
-
-(defun define-arm-gpr (name val)
-  (etypecase val
-    ((mod 16) (setf (gethash (string name) *arm-gprs*) val))
-    (symbol (let* ((defined (get-arm-gpr val)))
-              (if defined
-                (setf (gethash (string name) *arm-gprs*) defined)
-                (error "ARM register value ~s not defined" val))))))
+  (let* ((value (get-arm-register name)))
+    (and value (< value 16) value)))
+                      
+
+;;; This allows redefinition, which might be helpful while
+;;; boostrapping.  ARM-LAP-EQUATE-FORM checks for redefinition
+;;; before calling this.
+(defun define-arm-register (name val)
+  (let* ((value (if (typep val 'fixnum) val (get-arm-gpr val)))
+         (string (string name)))
+    (unless value
+      (error "invalid ARM register value ~d for ~s." val name))
+    (let* ((pair (assoc string *arm-register-names* :test #'string-equal)))
+      (if pair
+        (progn
+          (unless (eql (cdr pair) value)
+            (when ccl::*cerror-on-constant-redefinition*
+              (cerror "Redefine ARM register ~s to have value ~*~d."
+                      "ARM register ~s currently has value ~d."
+                      name (cdr pair) value)
+              (setf (cdr pair) value)))
+          (push (cons string value) *arm-register-names*))
+        value))))
 
 (defmacro defarmgpr (name val)
-  `(define-arm-gpr ',name ',val))
+  `(defconstant ,name (define-arm-register ',name ',val)))
 
 (defarmgpr r0 0)
@@ -198,4 +217,5 @@
 (defparameter *arm-subprims-base* (ash 4 12) )
 )
+(defvar *arm-subprims*)
 
 ;;; For now, nothing's nailed down and we don't say anything about
@@ -209,5 +229,5 @@
     (macrolet ((defarmsubprim (name)
                    `(define-arm-subprim ',name)))
-      (defparameter *arm-subprims*
+      (setq *arm-subprims*
         (vector
          (defarmsubprim .SPjmpsym)
@@ -1201,6 +1221,6 @@
   `(arm::%kernel-global ,name))
 
-(defarmarchmacro ccl::lfun-vector (fn)
-  fn)
+(defarmarchmacro ccl::lfun-vector (fun)
+  fun)
 
 (defarmarchmacro ccl::lfun-vector-lfun (lfv)
Index: /branches/arm/compiler/ARM/arm-asm.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-asm.lisp	(revision 13704)
+++ /branches/arm/compiler/ARM/arm-asm.lisp	(revision 13705)
@@ -40,6 +40,17 @@
       (error "Unknown ARM condition name ~s." name)))
 
+(defvar *arm-constants* ())
+(defvar *lap-labels* ())
+
+
 (defun arm-constant-index (form)
-  (error "NYI"))
+  (let* ((idx (or (assoc form *arm-constants* :test 'equal)
+                  (let* ((n (length *arm-constants*)))
+                    (push (cons form n) *arm-constants*)
+                    n))))
+    (+ (ash (+ idx 2) arm::word-shift)  ; skip entrypoint, codevector
+       arm::misc-data-offset)))
+
+           
 
 (defun need-constant (form)
@@ -66,4 +77,6 @@
   operand-types)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
 (ccl::defenum (:prefix "ARM-OPERAND-TYPE-")
   rd                                    ; destination register in bits 12:15
@@ -76,5 +89,6 @@
   uuo-unary                             ; constant in UUO bits 12:15
   uuoB                                  ; GPR in UUO bits 12:15
-  
+  rm
+  b
 )
 
@@ -89,4 +103,6 @@
     (:uuo-unary . ,arm-operand-type-uuo-unary)
     (:uuoB . ,arm-operand-type-uuoB)
+    (:rm . ,arm-operand-type-rm)
+    (:b . ,arm-operand-type-b)
     ))
 
@@ -117,4 +133,5 @@
             (setq mask (logior mask (encode-one-instruction-type n))))))
       0)))
+)
 
 (defmacro encode-arm-instruction-flag (name)
@@ -182,4 +199,9 @@
 (define-arm-instruction ldmia	#x8900000 () :rnw :reglist)
 (define-arm-instruction ldmfd	#x8900000 () :rnw :reglist)
+
+(define-arm-instruction b       #xa000000 () :b)
+(define-arm-instruction bl      #xb000000 () :b)
+(define-arm-instruction bx      #x12fff10 () :rm)
+(define-arm-instruction blx     #x12fff30 () :rm)
 
 ;;; UUOs
@@ -237,5 +259,9 @@
               (dotimes (i prefix-len)
                 (setf (schar prefix i) (schar string i)))
-              (if (setq template (gethash prefix *arm-instruction-templates*))
+              (if (setq template
+                        (progn
+                          (setq ordinal (gethash prefix *arm-instruction-ordinals*))
+                          (when ordinal
+                            (svref *arm-instruction-table* ordinal))))
                 (if (logbitp (encode-arm-instruction-flag :non-conditional) (arm-instruction-template-flags template))
                   (values nil nil nil)
@@ -547,4 +573,11 @@
   (set-field-value instruction 4 12 (need-arm-gpr form)))
 
+(defun parse-rm-operand (form instruction)
+  (set-field-value instruction 4 0 (need-arm-gpr form)))
+
+(defun parse-b-operand (form instruction)
+  (lap-note-label-reference form instruction :b))
+
+
 
 
@@ -560,4 +593,6 @@
       parse-uuo-unary-operand
       parse-uuob-operand
+      parse-rm-operand
+      parse-b-operand
       ))
 
@@ -595,3 +630,42 @@
           insn)))))
 
+;;; A label can only be emitted once.  Once it's been emitted, its pred/succ
+;;; slots will be non-nil.
+
+(defun lap-label-emitted-p (lab)
+  (not (null (lap-label-pred lab))))
+
+(defun %make-lap-label (name)
+  (let* ((lab (ccl::alloc-dll-node *lap-label-freelist*)))
+    (if lab
+      (progn
+        (setf (lap-label-address lab) nil
+              (lap-label-refs lab) nil
+              (lap-label-name lab) name)
+        lab)
+      (%%make-lap-label name))))
+
+(defun make-lap-label (name)
+  (let* ((lab (%make-lap-label name)))
+    (if (typep *lap-labels* 'hash-table)
+      (setf (gethash name *lap-labels*) lab)
+      (progn
+        (push lab *lap-labels*)
+        (if (> (length *lap-labels*) 255)
+          (let* ((hash (make-hash-table :size 512 :test #'eq)))
+            (dolist (l *lap-labels* (setq *lap-labels* hash))
+              (setf (gethash (lap-label-name l) hash) l))))))
+    lab))
+
+(defun find-lap-label (name)
+  (if (typep *lap-labels* 'hash-table)
+    (gethash name *lap-labels*)
+    (car (member name *lap-labels* :test #'eq :key #'lap-label-name))))
+
+(defun lap-note-label-reference (labx insn type)
+  (let* ((lab (or (find-lap-label labx)
+                  (make-lap-label labx))))
+    (push (cons insn type) (lap-label-refs lab))
+    lab))
+
 (provide "ARM-ASM")
Index: /branches/arm/compiler/ARM/arm-backend.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-backend.lisp	(revision 13704)
+++ /branches/arm/compiler/ARM/arm-backend.lisp	(revision 13705)
@@ -231,5 +231,5 @@
 
 
-#+linuxarm-target
+#+(or linuxarm-target (not arm-target))
 (defvar *linuxarm-backend*
   (make-backend :lookup-opcode #'arm::lookup-arm-instruction
@@ -278,5 +278,5 @@
                 :target-arch arm::*arm-target-arch*))
 
-#+linuxarm-target
+#+(or linuxarm-target (not arm-target))
 (pushnew *linuxarm-backend* *known-arm-backends* :key #'backend-name)
 
@@ -289,5 +289,5 @@
 (defun fixup-arm-backend ()
   (dolist (b *known-arm-backends*)
-    (setf (backend-lap-opcodes b) arm::*arm-opcodes*
+    (setf (backend-lap-opcodes b) arm::*arm-instruction-table*
 	  (backend-p2-dispatch b) *arm2-specials*
 	  (backend-p2-vinsn-templates b)  *arm-vinsn-templates*)
@@ -301,55 +301,52 @@
 #+arm-target
 (setq *host-backend* *arm-backend* *target-backend* *arm-backend*)
-#-arm-target
-(unless (backend-target-foreign-type-data *arm-backend*)
-  (let* ((ftd (make-ftd
-               :interface-db-directory
-               #+darwinarm-target "ccl:darwin-headers;"
-               #+linuxarm-target "ccl:headers;"
-               :interface-package-name
-               #+darwinarm-target "DARWIN32"
-               #+linuxarm-target "LINUX32"
-               :attributes
-               #+darwinarm-target
-               '(:signed-char t
-                 :struct-by-value t
-                 :prepend-underscores t
-                 :bits-per-word  32
-                 :poweropen-alignment t)
-               #+linuxarm-target
-               '(:bits-per-word 32)
-               :ff-call-expand-function
-               #+linuxarm-target
-               'linux32::expand-ff-call
-               #+darwinarm-target
-               'darwin32::expand-ff-call
-               :ff-call-struct-return-by-implicit-arg-function
-               #+linuxarm-target
-               linux32::record-type-returns-structure-as-first-arg
-               #+darwinarm-target
-               darwin32::record-type-returns-structure-as-first-arg
-               :callback-bindings-function
-               #+linuxarm-target
-               linux32::generate-callback-bindings
-               #+darwinarm-target
-               darwin32::generate-callback-bindings
-               :callback-return-value-function
-               #+linuxarm-target
-               linux32::generate-callback-return-value
-               #+darwinarm-target
-               darwin32::generate-callback-return-value
-               )))
-    (install-standard-foreign-types ftd)
-    (use-interface-dir :libc ftd)
-    (setf (backend-target-foreign-type-data *arm-backend*) ftd)))
+
+(defun setup-arm-ftd (backend)
+  (or (backend-target-foreign-type-data backend)
+      (let* ((name (backend-name backend))
+             (ftd
+              (case name
+                (:darwinarm
+                 (make-ftd :interface-db-directory "ccl:darwin-arm-headers;"
+			   :interface-package-name "ARM-DARWIN"
+                           :attributes '(:bits-per-word  32
+                                         :signed-char t
+                                         :struct-by-value t
+                                         :prepend-underscore nil)
+                           :ff-call-expand-function
+                           (intern "EXPAND-FF-CALL" "ARM-DARWIN")
+			   :ff-call-struct-return-by-implicit-arg-function
+                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
+                                   "ARM-DARWIN")
+                           :callback-bindings-function
+                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-DARWIN")
+                           :callback-return-value-function
+                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-DARWIN")))
+                (:linuxarm
+                 (make-ftd :interface-db-directory "ccl:arm-headers;"
+			   :interface-package-name "ARM-LINUX"
+                           :attributes '(:bits-per-word  32
+                                         :signed-char nil
+                                         :struct-by-value t
+                                         :float-results-in-x87 t)
+                           :ff-call-expand-function
+                           (intern "EXPAND-FF-CALL" "ARM-LINUX")
+			   :ff-call-struct-return-by-implicit-arg-function
+                           (intern "RECORD-TYPE-RETURNS-STRUCTURE-AS-FIRST-ARG"
+                                   "ARM-LINUX")
+                           :callback-bindings-function
+                           (intern "GENERATE-CALLBACK-BINDINGS" "ARM-LINUX")
+                           :callback-return-value-function
+                           (intern "GENERATE-CALLBACK-RETURN-VALUE" "ARM-LINUX"))))))
+        (install-standard-foreign-types ftd)
+        (use-interface-dir :libc ftd)
+        (setf (backend-target-foreign-type-data backend) ftd))))
 
 (pushnew *arm-backend* *known-backends* :key #'backend-name)
 
+#+notyet
 (require "ARM-VINSNS")
 
-(defparameter *arm-backend*
-  #+arm-target *arm-backend*
-  #-(or arm-target)
-  nil)
+
 
 
Index: /branches/arm/compiler/ARM/arm-lap.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-lap.lisp	(revision 13704)
+++ /branches/arm/compiler/ARM/arm-lap.lisp	(revision 13705)
@@ -30,5 +30,5 @@
 (defun (setf arm-lap-macro-function) (def name)
   (let* ((s (string name)))
-    (when (gethash s arm::*arm-instruction-templates*)
+    (when (gethash s arm::*arm-instruction-ordinals*)
       (error "~s already defines an arm instruction . " name))
     (setf (gethash s (backend-lap-macros *arm-backend*)) def)))
@@ -42,6 +42,4 @@
 
 (defvar *arm-lap-constants* ())
-(defvar *arm-lap-labels* ())
-(defvar *arm-lap-instructions*)
 (defvar *arm-lap-regsave-reg* ())
 (defvar *arm-lap-regsave-addr* ())
@@ -50,4 +48,17 @@
 
 
+(defmacro do-lap-labels ((lab &optional result) &body body)
+  (let* ((thunk-name (gensym))
+         (k (gensym))
+         (xlab (gensym)))
+    `(flet ((,thunk-name (,lab) ,@body))
+      (if (listp arm::*lap-labels*)
+        (dolist (,xlab arm::*lap-labels*)
+          (,thunk-name ,xlab))
+        (maphash #'(lambda (,k ,xlab)
+                     (declare (ignore ,k))
+                     (,thunk-name ,xlab))
+                 arm::*lap-labels*))
+      ,result)))
 
 
@@ -66,11 +77,10 @@
 
 (defun %define-arm-lap-function (name body &optional (bits 0))
-  (with-dll-node-freelist (*lap-instructions* *lap-instruction-freelist*)
+  (with-dll-node-freelist (*lap-instructions* arm::*lap-instruction-freelist*)
       (let* ((*lap-labels* ())
-             (*arm-lap-constants* ())
+             (arm::*arm-constants* ())
              (*arm-lap-lfun-bits* bits))
         (dolist (form body)
           (arm-lap-form form))
-        #+arm-lap-scheduler (arm-schedule-instuctions)       ; before resolving branch targets
         (arm-lap-generate-code name (arm-lap-do-labels) *arm-lap-lfun-bits*))))
 
@@ -81,6 +91,6 @@
     (declare (fixnum pc))
     (do-dll-nodes (node *lap-instructions*)
-      (setf (instruction-element-address node) pc)
-      (if (typep node 'lap-label)
+      (setf (arm::instruction-element-address node) pc)
+      (if (typep node 'arm::lap-label)
         (if delete-labels-p (remove-dll-node node))
         (incf pc 4)))
@@ -92,7 +102,7 @@
 (defun arm-lap-do-labels ()
   (do-lap-labels (lab)
-    (if (and (lap-label-refs lab) (not (lap-label-emitted-p lab)))
+    (if (and (arm::lap-label-refs lab) (not (arm::lap-label-emitted-p lab)))
       (error "Label ~S was referenced but never defined. " 
-             (lap-label-name lab)))
+             (arm::lap-label-name lab)))
     ;; Repeatedly iterate through label's refs, until none of them is
     ;; the preceding instruction.  This eliminates
@@ -102,17 +112,13 @@
     ;; but can probably be fooled by hairier nonsense.
     (loop
-      (when (dolist (ref (lap-label-refs lab) t)
-              (when (eq lab (lap-instruction-succ ref))
+      (when (dolist (ref (arm::lap-label-refs lab) t)
+              (when (eq lab (arm::lap-instruction-succ ref))
                 (remove-dll-node ref)
-                (setf (lap-label-refs lab) (delete ref (lap-label-refs lab)))
+                (setf (arm::lap-label-refs lab) (delete ref (arm::lap-label-refs lab)))
                 (return)))
         (return))))
   ;; Assign pc to emitted labels, splice them out of the list.
   
-  (if (> (the fixnum (dll-header-length *lap-instructions*)) 8191)
-    ;; -Might- have some conditional branches that are too long.
-    ;; Definitely don't  otherwise, so only bother to check in this case
-    (arm-lap-remove-long-branches)
-    (arm-lap-assign-addresses t)))
+    (arm-lap-assign-addresses t))
 
 ;;; Replace each label with the difference between the label's address
@@ -120,10 +126,10 @@
 (defun arm-lap-resolve-labels ()
   (do-lap-labels (label)
-    (let* ((label-address (lap-label-address label)))
+    (let* ((label-address (arm::lap-label-address label)))
       (declare (fixnum label-address))          ; had BETTER be ...
-      (dolist (insn (lap-label-refs label))
-        (let* ((diff (- label-address (lap-instruction-address insn))))
+      (dolist (insn (arm::lap-label-refs label))
+        (let* ((diff (- label-address (arm::lap-instruction-address insn))))
           (declare (fixnum diff))
-          (let* ((opvals (lap-instruction-parsed-operands insn))
+          (let* ((opvals (arm::lap-instruction-parsed-operands insn))
                  (pos (position label opvals)))
             (unless pos
@@ -132,5 +138,5 @@
 
 (defun arm-lap-generate-instruction (code-vector index insn)
-  (let* ((op (lap-instruction-opcode insn))
+  (let* ((op (arm::lap-instruction-opcode insn))
          (vals (lap-instruction-parsed-operands insn))
          (high (opcode-op-high op))
@@ -156,61 +162,16 @@
      nil)))
 
-(defparameter *use-traceback-tables* nil)
-
-(defun traceback-fullwords (pname)
-  (if (and *use-traceback-tables* pname (typep pname 'simple-base-string))
-    (ceiling (+ 22 (length pname)) 4)
-    0))
-
-(defun add-traceback-table (code-vector start pname)
-  (flet ((out-byte (v i8 b)
-            (declare (type (simple-array (unsigned-byte 8) (*)) v)
-                    (optimize (speed 3) (safety 0))
-                    (fixnum i8))
-            (setf (aref v i8) b)))          
-    (flet ((out-bytes (v i32 b0 b1 b2 b3)
-           (declare (type (simple-array (unsigned-byte 8) (*)) v)
-                    (optimize (speed 3) (safety 0))
-                    (fixnum i32))
-           (let* ((i8 (ash i32 2)))
-             (declare (fixnum i8))
-             (setf (aref v i8) b0
-                   (aref v (%i+ i8 1)) b1
-                   (aref v (%i+ i8 2)) b2
-                   (aref v (%i+ i8 3)) b3))))
-      (setf (uvref code-vector start) 0)
-      (out-bytes code-vector (1+ start)
-                 0                          ; traceback table version
-                 0                          ; language id 7 - try 0 instead (means C) or 9 means C++
-                 #x20                       ; ???
-                 #x41)                      ; ???
-      (out-bytes code-vector (+ start 2)
-                 #x80 #x06 #x01 #x00)       ; ??? ??? ??? ???
-      (setf (uvref code-vector (+ start 3)) #x0)
-      (setf (uvref code-vector (+ start 4)) (ash start 2))
-      (let* ((namelen (length pname))
-             (pos (ash (the fixnum (+ start 5)) 2)))
-        (declare (fixnum namelen pos))
-        (out-byte code-vector pos (ldb (byte 8 8) namelen))
-        (incf pos)
-        (out-byte code-vector pos (ldb (byte 8 0) namelen))
-        (incf pos)
-        (dotimes (i namelen) 
-          (out-byte code-vector pos (char-code (schar pname i)))
-          (incf pos))))))
-
-(defun arm-lap-generate-code (name maxpc bits &optional (traceback nil))
+
+
+(defun arm-lap-generate-code (name maxpc bits)
   (declare (fixnum maxpc))
   (let* ((target-backend *target-backend*)
          (cross-compiling (not (eq *host-backend* target-backend)))
-	 (traceback-size
-	  (traceback-fullwords (and traceback
-				    name
-				    (setq traceback (symbol-name name)))))
+
          (prefix (arch::target-code-vector-prefix (backend-target-arch *target-backend*)))
          (prefix-size (length prefix))
-         (code-vector-size (+ (ash maxpc -2) traceback-size prefix-size))
-
-         (constants-size (+ 3 (length *arm-lap-constants*)))
+         (code-vector-size (+ (ash maxpc -2) prefix-size))
+
+         (constants-size (+ 4 (length *arm-lap-constants*)))
          (constants-vector (%alloc-misc
                             constants-size
@@ -220,11 +181,9 @@
          (i prefix-size))
     (declare (fixnum i constants-size))
-    #+arm32-target
-    (if (>= code-vector-size (ash 1 19)) (compiler-function-overflow))
     (let* ((code-vector (%alloc-misc
                          code-vector-size
                          (if cross-compiling
                            target::subtag-xcode-vector
-                           target::subtag-code-vector))))
+                           arm::subtag-code-vector))))
       (dotimes (j prefix-size)
         (setf (uvref code-vector j) (pop prefix)))
@@ -233,6 +192,5 @@
         (arm-lap-generate-instruction code-vector i insn)
         (incf i))
-      (unless (eql 0 traceback-size)
-        (add-traceback-table code-vector i traceback))
+
       (dolist (immpair *arm-lap-constants*)
         (let* ((imm (car immpair))
@@ -252,20 +210,4 @@
 (defun arm-lap-pseudo-op (form)
   (case (car form)
-    (:regsave
-     (if *arm-lap-regsave-label*
-       (warn "Duplicate :regsave form not handled (yet ?) : ~s" form)
-       (destructuring-bind (reg addr) (cdr form)
-         (let* ((regno (arm-register-name-or-expression reg)))
-           (if (not (<= arm::save7 regno arm::save0))
-             (warn "Not a save register: ~s.  ~s ignored." reg form)
-             (let* ((addrexp (arm-register-name-or-expression addr)))   ; parses 'fixnum
-               (if (not (and (typep addrexp 'fixnum)
-                             (<= 0 addrexp #x7ffc)      ; not really right
-                             (not (logtest 3 addrexp))))
-                 (warn "Invalid logical VSP: ~s.  ~s ignored." addr form)
-                 (setq *arm-lap-regsave-label* (emit-lap-label (gensym))
-                       *arm-lap-regsave-reg* regno
-                       *arm-lap-regsave-addr* (- (+ addrexp)
-                                                 (* 4 (1+ (- arm::save0 regno))))))))))))
     (:arglist (setq *arm-lap-lfun-bits* (encode-lambda-list (cadr form))))))
 
@@ -287,33 +229,30 @@
                 ((let) (arm-lap-equate-form (cadr form) (cddr form)))
                 (t
-                 ; instruction macros expand into instruction forms
-                 ; (with some operands reordered/defaulted.)
-                 (let* ((expander (arm::arm-macro-function name)))
-                   (if expander
-                     (arm-lap-form (funcall expander form nil))
-                     (arm-lap-instruction name (cdr form)))))))))))))
+                 (arm-lap-instruction name (cdr form)))))))))))
 
 ;;; (let ((name val) ...) &body body)
 ;;; each "val" gets a chance to be treated as a ARM register name
 ;;; before being evaluated.
-(defun arm-lap-equate-form (eqlist body) 
-  (let* ((symbols (mapcar #'(lambda (x)
-                              (let* ((name (car x)))
-                                (or
-                                 (and name 
-                                      (symbolp name)
-                                      (not (constant-symbol-p name))
-                                      name)
-                                 (error 
-                                  "~S is not a bindable symbol name ." name))))
-                          eqlist))
-         (values (mapcar #'(lambda (x) (or (arm-vr-name-p (cadr x))
-					   (arm-fpr-name-p (cadr x))
-					   (arm-register-name-or-expression
-					    (cadr x))))
-                         eqlist)))
-    (progv symbols values
-                   (dolist (form body)
-                     (arm-lap-form form)))))
+(defun arm-lap-equate-form (eqlist body)
+  (collect ((symbols)
+            (values))
+    (let* ((arm::*arm-register-names* arm::*arm-register-names*))
+      (dolist (pair eqlist)
+        (destructuring-bind (symbol value) pair
+          (unless (and symbol
+                       (symbolp symbol)
+                       (not (constant-symbol-p symbol))
+                       (not (arm::get-arm-register symbol)))
+            (error "~s is not a bindable symbol name . " symbol))
+          (let* ((regval (arm::get-arm-register value)))
+            (if regval
+              (arm::define-arm-register symbol regval)
+              (progn
+                (symbols symbol)
+                (values (eval value)))))))
+
+    (progv (symbols) (values)
+      (dolist (form body)
+        (arm-lap-form form))))))
 
 (defun arm-lap-constant-offset (x)
Index: /branches/arm/compiler/ARM/arm-lapmacros.lisp
===================================================================
--- /branches/arm/compiler/ARM/arm-lapmacros.lisp	(revision 13704)
+++ /branches/arm/compiler/ARM/arm-lapmacros.lisp	(revision 13705)
@@ -31,5 +31,4 @@
       (cmp nargs (:$ (ash ,min arm::fixnumshift)))
       (uuo-error-wrong-nargs (:? ne)))
-    `(trnei nargs ',min)
     (if (null max)
       (unless (= min 0)
@@ -243,67 +242,50 @@
       (push inst insts))))
 
-(defarmlapmacro get-single-float (dest node)
-  (target-arch-case
-   (:ppc32
-    `(lfs ,dest ppc32::single-float.value ,node))
-   (:ppc64
-    `(progn
-      (std ,node ppc64::tcr.single-float-convert ppc64::rcontext)
-      (lfs ,dest ppc64::tcr.single-float-convert ppc64::rcontext)))))
+(defarmlapmacro get-single-float (dest node temp)
+  `(progn
+    (ldr ,temp (:@ ,node (:$ arm::single-float.value)))
+    (fmsr ,dest ,temp)))
 
 (defarmlapmacro get-double-float (dest node)
-  (target-arch-case
-   (:ppc32
-    `(lfd ,dest ppc32::double-float.value ,node))
-   (:ppc64
-    `(lfd ,dest ppc64::double-float.value ,node))))
+  `(progn
+    (ldrdd imm0 imm1 (:@ ,node (:$ arm::double-float.value)))
+    (fmdrr ,dest imm0 imm1)))
   
 
-(defarmlapmacro put-single-float (src node)
-  (target-arch-case
-   (:ppc32
-    `(stfs ,src ppc32::single-float.value ,node))
-   (:ppc64
-    `(progn
-      (stfs ,src ppc64::tcr.single-float-convert ppc64::rcontext)
-      (ld ,node ppc64::tcr.single-float-convert ppc64::rcontext)))))
+(defarmlapmacro put-single-float (src node temp)
+  `(progn
+    (fmrs ,temp ,src)
+    (str ,temp (:@ ,node (:$ arm::single-float.value))))
 
 (defarmlapmacro put-double-float (src node)
-  (target-arch-case
-   (:ppc32
-    `(stfd ,src ppc32::double-float.value ,node))
-   (:ppc64
-    `(stfd ,src ppc64::double-float.value ,node))))
+  `(progn
+    (fmrrd imm0 imm1 ,src)
+    (strdd imm0 imm1 (:@ ,node (:$ arm::double-float.value)))))
+
 
 (defarmlapmacro clear-fpu-exceptions ()
-  `(mtfsf #xfc #.ppc::fp-zero))
-
-
-
-;;; from ppc-bignum.lisp
+  (error "Later."))
+
+
+
 (defarmlapmacro digit-h (dest src)
-  (target-arch-case
-   (:ppc32
-    `(rlwinm ,dest ,src (+ 16 ppc32::fixnumshift) (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnumshift)))
-   (:ppc64
-    (error "DIGIT-H on PPC64 ?"))))
-
-;;; from ppc-bignum.lisp
+  `(progn
+    (mov ,dest (:$ (ash #xff arm::fixnumshift)))
+    (orr ,dest ,dest (:lsl ,dest (:$ 8)))
+    (and ,dest ,dest (:lsr ,src  (:$ (- 16 arm::fixnumshift))))))
+
 (defarmlapmacro digit-l (dest src)
-  (target-arch-case
-   (:ppc32
-    `(clrlslwi ,dest ,src 16 ppc32::fixnumshift))
-   (:ppc64
-    (error "DIGIT-L on PPC64 ?"))))
+  `(progn
+    (mov ,dest (:$ (ash #xff arm::fixnumshift)))
+    (orr ,dest ,dest (:lsl ,dest (:$ 8)))
+    (and ,dest ,dest (:lsl ,src  (:$ arm::fixnumshift)))))
   
-;;; from ppc-bignum.lisp
+
 (defarmlapmacro compose-digit (dest high low)
-  (target-arch-case
-   (:ppc32
-    `(progn
-      (rlwinm ,dest ,low (- ppc32::nbits-in-word ppc32::fixnumshift) 16 31)
-      (rlwimi ,dest ,high (- 16 ppc32::fixnumshift) 0 15)))
-   (:ppc64
-    (error "COMPOSE-DIGIT on PPC64 ?"))))
+  ;; Can we assume that HIGH and LOW are boxed 16-bit fixnums ?
+  ;; This code does ...
+  `(progn
+    (mov ,dest (:lsl ,high (:$ (- 16 arm::fixnumshift))))
+    (orr ,dest ,dest (:lsr ,low (:$ arm::fixnumshift)))))
 
 (defarmlapmacro macptr-ptr (dest macptr)
@@ -323,14 +305,10 @@
          (one (gensym)))
   `(progn
-     (cmpri cr1 nargs '2)
-     (cmpri cr0 nargs 0)
-     (beq cr1 ,two)
-     (beq cr0 ,none)
-     (blt cr1 ,one)
-     (vpush arg_x)
-     ,two
-     (vpush arg_y)
-     ,one
-     (vpush arg_z)
+    (cmp nargs (:$ 0))
+    (beq ,none)
+    (cmp nargs '2)
+    (strgt arg_x (:@! vsp (:$ (- arm::node-size))))
+    (strge arg_y (:@! vsp (:$ (- arm::node-size))))
+    (str arg_z (:@! vsp (:$ (- arm::node-size))))
      ,none)))