diff --git a/compiler/rt/afpa.lisp b/compiler/rt/afpa.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..e53d3c711a276db6367e11d9d8001ef1542feb85
--- /dev/null
+++ b/compiler/rt/afpa.lisp
@@ -0,0 +1,499 @@
+;;; -*- Package: RT -*-
+;;;
+;;; **********************************************************************
+;;; This code was written as part of the CMU Common Lisp project at
+;;; Carnegie Mellon University, and has been placed in the public domain.
+;;; If you want to use this code or any part of CMU Common Lisp, please contact
+;;; Scott Fahlman or slisp-group@cs.cmu.edu.
+;;;
+(ext:file-comment
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/afpa.lisp,v 1.1 1991/07/23 12:14:16 ram Exp $")
+;;;
+;;; **********************************************************************
+;;;
+;;; The following code is to support the AFPA on the EAPC card and the
+;;; accessory AFPA for the APC card.  There isn't heavy use of AFPA features;
+;;; other than the size of the register set, and the DMA use, this would work
+;;; on the FPA (supposing anyone still has one of those.)  This is adapted from
+;;; the 68881 support, and from the MIPS support.
+;;;
+;;; See section 4 in Vol 1 of the RT technical manual.  In particular DMA is
+;;; described on 4-96 to 4-98.
+;;;
+(in-package "RT")
+
+
+;;;; Status register formats.
+
+(defconstant afpa-rounding-mode-byte (byte 2 (- 31 24)))
+(defconstant afpa-compare-result-byte (byte 2 (- 31 22)))
+
+;;; The condition code bits.
+;;;
+(defconstant afpa-compare-lss #b00)
+(defconstant afpa-compare-eql #b01)
+(defconstant afpa-compare-gtr #b10)
+(defconstant afpa-compare-unordered #b11)
+
+
+;;;; Move functions:
+;;;
+;;;    Since moving between memory and a FP register reqires *two* temporaries,
+;;; we need a special temporary to form the magic address we store to do a
+;;; floating point operation.  We get this temp by always spilling NL0 on the
+;;; number stack.  See WITH-FP-TEMP in the 68881 support.
+;;;
+;;; We also use LIP to form the address of the data location that we are
+;;; reading or writing.
+
+
+(define-move-function (load-afpa-single 7) (vop x y)
+  ((single-stack) (afpa-single-reg))
+  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
+  (with-fp-temp (temp)
+    (inst afpa-load y lip-tn :single temp)
+    (inst afpa-noop temp)))
+
+(define-move-function (store-single 8) (vop x y)
+  ((afpa-single-reg) (single-stack))
+  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
+  (with-fp-temp (temp)
+    (inst afpa-store x lip-tn :single temp)
+    (inst afpa-noop temp)))
+
+(define-move-function (load-double 7) (vop x y)
+  ((double-stack) (afpa-double-reg))
+  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset x) vm:word-bytes))
+  (with-fp-temp (temp)
+    (inst afpa-load y lip-tn :double temp)
+    (inst afpa-noop temp)))
+
+(define-move-function (store-double 8) (vop x y)
+  ((afpa-double-reg) (double-stack))
+  (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
+  (with-fp-temp (temp)
+    (inst afpa-store x lip-tn :double temp)
+    (inst afpa-noop temp)))
+
+
+;;;; Move VOPs:
+
+
+(macrolet ((frob (vop sc inst)
+	     `(progn
+		(define-vop (,vop)
+		  (:args (x :scs (,sc)
+			    :target y
+			    :load-if (not (location= x y))))
+		  (:results (y :scs (,sc)
+			       :load-if (not (location= x y))))
+		  (:note "float move")
+		  (:temporary (:sc sap-reg) temp)
+		  (:generator 0
+		    (unless (location= y x)
+		      (inst afpa-unop y x ,inst temp))))
+		(define-move-vop ,vop :move (,sc) (,sc)))))
+  (frob afpa-single-move afpa-single-reg :cops)
+  (frob afpa-double-move afpa-double-reg :copl))
+
+
+
+(macrolet ((frob (name format data sc)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (descriptor-reg)))
+		  (:results (y :scs (,sc)))
+		  (:temporary (:sc sap-reg) temp)
+		  (:generator 7
+		    (inst cal lip-tn x (- (* ,data vm:word-bytes)
+					  vm:other-pointer-type))
+		    (inst afpa-load y lip-tn ,format temp)
+		    (inst afpa-noop temp)))
+		(define-move-vop ,name :move (descriptor-reg) (,sc)))))
+  (frob move-to-afpa-single :single vm:single-float-value-slot
+    afpa-single-reg)
+  (frob move-to-afpa-double :double vm:double-float-value-slot
+    afpa-double-reg))
+
+
+
+(macrolet ((frob (name sc format size type data)
+	     `(progn
+		(define-vop (,name)
+		  (:args (x :scs (afpa-single-reg afpa-double-reg) :to :save))
+		  (:results (y :scs (descriptor-reg)))
+		  (:temporary (:scs (sap-reg)) ndescr)
+		  (:temporary (:scs (word-pointer-reg)) alloc)
+		  (:generator 20
+		    (with-fixed-allocation (y ndescr alloc ,type ,size)
+		      (inst cal lip-tn y (- (* ,data vm:word-bytes)
+					    vm:other-pointer-type))
+		      (inst afpa-store x lip-tn ,format ndescr)
+		      (inst afpa-noop ndescr))))
+		(define-move-vop ,name :move (,sc) (descriptor-reg)))))
+  (frob move-from-afpa-single afpa-single-reg
+    :single vm:single-float-size vm:single-float-type
+    vm:single-float-value-slot)
+  (frob move-from-afpa-double afpa-double-reg
+    :double vm:double-float-size vm:double-float-type
+    vm:double-float-value-slot))
+
+(define-vop (move-to-afpa-argument)
+  (:args (x :scs (afpa-single-reg afpa-double-reg))
+	 (nfp :scs (word-pointer-reg)
+	      :load-if (not (sc-is y afpa-single-reg afpa-double-reg))))
+  (:results (y))
+  (:temporary (:sc sap-reg) temp)
+  (:variant-vars format)
+  (:vop-var vop)
+  (:generator 7
+    (sc-case y
+      ((afpa-single-reg afpa-double-reg)
+       (unless (location= y x)
+	 (inst afpa-move y x format temp)))
+      ((single-stack double-stack)
+       (inst cal lip-tn (current-nfp-tn vop) (* (tn-offset y) vm:word-bytes))
+       (inst afpa-store y lip-tn format temp)
+       (inst afpa-noop temp)))))
+
+(macrolet ((frob (name format sc)
+	     `(progn
+		(define-vop (,name move-to-afpa-argument)
+		  (:variant ,format))
+		(define-move-vop ,name :move-argument
+		  (,sc descriptor-reg) (,sc)))))
+  (frob move-afpa-single-float-argument :single afpa-single-reg)
+  (frob move-afpa-double-float-argument :double afpa-double-reg))
+
+(define-move-vop move-argument :move-argument
+  (afpa-single-reg afpa-double-reg) (descriptor-reg))
+
+
+;;;; Arithmetic VOPs:
+
+(define-vop (afpa-op)
+  (:args (x) (y))
+  (:results (r))
+  (:temporary (:sc sap-reg) temp)
+  (:policy :fast-safe)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:note "inline float arithmetic")
+  (:vop-var vop)
+  (:save-p :compute-only))
+
+(macrolet ((frob (name sc ptype format)
+	     `(define-vop (,name afpa-op)
+		(:args (x :scs (,sc) :target r)
+		       (y :scs (,sc)))
+		(:results (r :scs (,sc) :from (:argument 0)))
+		(:arg-types ,ptype ,ptype)
+		(:result-types ,ptype)
+		(:variant-vars op)
+		(:generator 20
+		  (unless (location= x r)
+		    (inst afpa-move r x ,format temp))
+		  (note-this-location vop :internal-error)
+		  (inst afpa-binop r y op temp)))))
+  (frob afpa-single-float-op afpa-single-reg afpa-single-float :single)
+  (frob afpa-double-float-op afpa-double-reg afpa-double-float :double))
+
+(macrolet ((frob (op sinst sname dinst dname)
+	     `(progn
+		(define-vop (,sname afpa-single-float-op)
+		  (:translate ,op)
+		  (:variant ,sinst))
+		(define-vop (,dname afpa-double-float-op)
+		  (:translate ,op)
+		  (:variant ,dinst)))))
+  (frob + :adds +/single-float :addl +/double-float)
+  (frob - :subs -/single-float :subl -/double-float)
+  (frob * :muls */single-float :mull */double-float)
+  (frob / :divs //single-float :divl //double-float))
+
+(define-vop (afpa-unop afpa-op)
+  (:args (x)))
+
+(macrolet ((frob (name sc ptype)
+	     `(define-vop (,name afpa-unop)
+		(:args (x :scs (,sc)))
+		(:results (r :scs (,sc)))
+		(:arg-types ,ptype)
+		(:result-types ,ptype)
+		(:variant-vars op)
+		(:generator 20
+		  (inst afpa-unop r x op temp)))))
+  (frob afpa-single-float-unop afpa-single-reg afpa-single-float)
+  (frob afpa-double-float-unop afpa-double-reg afpa-double-float))
+
+
+(macrolet ((frob (op sinst sname dinst dname)
+	     `(progn
+		(define-vop (,sname afpa-single-float-unop)
+		  (:translate ,op)
+		  (:variant ,sinst))
+		(define-vop (,dname afpa-double-float-unop)
+		  (:translate ,op)
+		  (:variant ,dinst)))))
+  (frob abs :abss abs/single-float :absl abs/double-float)
+  (frob %negate :negs %negate/single-float :negl %negate/double-float))
+
+
+;;;; Comparison:
+
+(define-vop (afpa-compare)
+  (:args (x) (y))
+  (:conditional)
+  (:info target not-p)
+  (:policy :fast-safe)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:temporary (:sc sap-reg) temp)
+  (:variant-vars condition format)
+  (:note "inline float comparison")
+  (:vop-var vop)
+  (:save-p :compute-only)
+  (:generator 15
+    (note-this-location vop :internal-error)
+    (inst afpa-compare x y
+	  (ecase format
+	    (:single :comts)
+	    (:double :comtl))
+	  temp)
+    (inst afpa-get-status temp temp)
+    (inst nilz temp temp (mask-field afpa-compare-result-byte -1))
+    (inst c temp (dpb condition afpa-compare-result-byte 0))
+    (if not-p
+	(inst bnc :eq target)
+	(inst bc :eq target))))
+
+
+(macrolet ((frob (name sc ptype)
+	     `(define-vop (,name afpa-compare)
+		(:args (x :scs (,sc))
+		       (y :scs (,sc)))
+		(:arg-types ,ptype ,ptype))))
+  (frob afpa-single-float-compare afpa-single-reg afpa-single-float)
+  (frob afpa-double-float-compare afpa-double-reg afpa-double-float))
+
+(macrolet ((frob (translate sname dname condition)
+	     `(progn
+		(define-vop (,sname afpa-single-float-compare)
+		  (:translate ,translate)
+		  (:variant ,condition :single))
+		(define-vop (,dname afpa-double-float-compare)
+		  (:translate ,translate)
+		  (:variant ,condition :double)))))
+  (frob < afpa-</single-float afpa-</double-float afpa-compare-lss)
+  (frob > afpa->/single-float afpa->/double-float afpa-compare-gtr)
+  (frob eql afpa-eql/single-float afpa-eql/double-float afpa-compare-eql))
+
+
+;;;; Conversion:
+
+(macrolet ((frob (name translate
+		       from-sc from-type
+		       to-sc to-type
+		       word-p op)
+	     `(define-vop (,name)
+		(:args (x :scs (,from-sc)))
+		(:results (y :scs (,to-sc)))
+		(:arg-types ,from-type)
+		(:result-types ,to-type)
+		(:temporary (:sc sap-reg) temp)
+		(:policy :fast-safe)
+		(:guard (eq *target-float-hardware* :afpa))
+		(:note "inline float coercion")
+		(:translate ,translate)
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 10
+		  (note-this-location vop :internal-error)
+		  ,@(if word-p
+			`((inst afpa-put-float-inst y x temp
+				(do-afpa-inst ,op temp :fr2 y :data x
+					      :ds :fr1-immediate)))
+			`((inst afpa-unop y x ,op temp)))))))
+  (frob %afpa-single-float/signed %single-float
+    signed-reg signed-num
+    afpa-single-reg afpa-single-float
+    t :cws)
+  (frob %afpa-double-float/signed %double-float
+    signed-reg signed-num
+    afpa-double-reg afpa-double-float
+    t :cwl)
+  (frob %afpa-single-float/double-float %single-float
+    afpa-double-reg afpa-double-float
+    afpa-single-reg afpa-single-float
+    nil :cls)
+  (frob %afpa-double-float/single-float %double-float
+    afpa-single-reg afpa-single-float
+    afpa-double-reg afpa-double-float
+    nil :csl))
+
+(macrolet ((frob (translate name from-sc from-type op)
+	     `(define-vop (,name)
+		(:args (x :scs (,from-sc)))
+		(:results (y :scs (signed-reg)))
+		(:temporary (:from (:argument 0) :sc ,from-sc) fp-temp)
+		(:temporary (:sc sap-reg) temp)
+		(:arg-types ,from-type)
+		(:result-types signed-num)
+		(:translate ,translate)
+		(:policy :fast-safe)
+		(:guard (eq *target-float-hardware* :afpa))
+		(:note "inline float round/truncate")
+		(:vop-var vop)
+		(:save-p :compute-only)
+		(:generator 10
+		  (note-this-location vop :internal-error)
+		  (inst afpa-unop fp-temp x ,op temp)
+		  (inst afpa-get-float y temp fp-temp)))))
+
+  (frob %unary-round %unary-round/afpa-single-float
+    afpa-single-reg afpa-single-float :rsw)
+  (frob %unary-round %unary-round/afpa-double-float
+    afpa-double-reg afpa-double-float :rlw)
+  (frob %unary-truncate %unary-truncate/afpa-single-float
+    afpa-single-reg afpa-single-float :tsw)
+  (frob %unary-truncate %unary-truncate/afpa-double-float
+    afpa-double-reg afpa-double-float :tlw))
+
+
+(define-vop (make-afpa-single-float)
+  (:args (bits :scs (signed-reg)))
+  (:results (res :scs (afpa-single-reg)))
+  (:arg-types signed-num)
+  (:temporary (:sc sap-reg) temp)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:result-types afpa-single-float)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:generator 5
+    (inst afpa-put-float res bits temp)))
+
+(define-vop (make-afpa-double-float)
+  (:args (hi-bits :scs (signed-reg))
+	 (lo-bits :scs (unsigned-reg)))
+  (:results (res :scs (afpa-double-reg)))
+  (:temporary (:sc sap-reg) temp)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:arg-types signed-num unsigned-num)
+  (:result-types afpa-double-float)
+  (:translate make-double-float)
+  (:policy :fast-safe)
+  (:generator 10
+    (inst afpa-put-float-odd res lo-bits temp)
+    (inst afpa-put-float res hi-bits temp)))
+
+(define-vop (afpa-single-float-bits)
+  (:args (float :scs (afpa-single-reg)))
+  (:results (bits :scs (signed-reg)))
+  (:temporary (:sc sap-reg) temp)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:arg-types afpa-single-float)
+  (:result-types signed-num)
+  (:translate single-float-bits)
+  (:policy :fast-safe)
+  (:generator 5
+    (inst afpa-get-float bits float temp)))
+
+(define-vop (afpa-double-float-high-bits)
+  (:args (float :scs (afpa-double-reg)))
+  (:results (hi-bits :scs (signed-reg)))
+  (:temporary (:sc sap-reg) temp)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:arg-types afpa-double-float)
+  (:result-types signed-num)
+  (:translate double-float-high-bits)
+  (:policy :fast-safe)
+  (:generator 5
+    (inst afpa-get-float hi-bits float temp)))
+
+(define-vop (afpa-double-float-low-bits)
+  (:args (float :scs (afpa-double-reg)))
+  (:results (lo-bits :scs (unsigned-reg)))
+  (:temporary (:sc sap-reg) temp)
+  (:guard (eq *target-float-hardware* :afpa))
+  (:arg-types afpa-double-float)
+  (:result-types unsigned-num)
+  (:translate double-float-low-bits)
+  (:policy :fast-safe)
+  (:generator 5
+    (inst afpa-get-float-odd lo-bits float temp)))
+
+
+;;;; SAP accessors/setters
+
+#|
+(define-vop (sap-ref-afpa-single sap-ref)
+  (:translate sap-ref-single)
+  (:results (result :scs (afpa-single-reg)))
+  (:result-types afpa-single-float)
+  (:variant :afpa-single nil))
+
+(define-vop (sap-set-afpa-single sap-set)
+  (:translate %set-sap-ref-single)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (any-reg signed-reg zero immediate))
+	 (value :scs (afpa-single-reg) :target result))
+  (:arg-types system-area-pointer positive-fixnum afpa-single-float)
+  (:results (result :scs (afpa-single-reg)))
+  (:result-types afpa-single-float)
+  (:variant :afpa-single))
+
+(define-vop (sap-ref-afpa-double sap-ref)
+  (:translate sap-ref-double)
+  (:results (result :scs (afpa-double-reg)))
+  (:result-types afpa-double-float)
+  (:variant :afpa-double nil))
+
+(define-vop (sap-set-afpa-double sap-set)
+  (:translate %set-sap-ref-double)
+  (:args (sap :scs (sap-reg))
+	 (offset :scs (signed-reg any-reg zero immediate))
+	 (value :scs (afpa-double-reg) :target result))
+  (:arg-types system-area-pointer positive-fixnum afpa-double-float)
+  (:results (result :scs (afpa-double-reg)))
+  (:result-types afpa-double-float)
+  (:variant :afpa-double))
+
+|#
+
+
+;;;; Float mode hackery:
+
+(deftype float-modes () '(unsigned-byte 32))
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+  float-modes)
+
+(define-vop (floating-point-modes)
+  (:results (res :scs (unsigned-reg)))
+  (:result-types unsigned-num)
+  (:translate floating-point-modes)
+  (:policy :fast-safe)
+  #+nil (:vop-var vop)
+  #+nil (:temporary (:sc unsigned-stack) temp)
+  (:generator 3
+    #+nil
+    (let ((nfp (current-nfp-tn vop)))
+      (inst stfsr nfp (* word-bytes (tn-offset temp)))
+      (loadw res nfp (tn-offset temp))
+      (inst nop))
+    (inst li res 0)))
+
+(define-vop (set-floating-point-modes)
+  (:args (new :scs (unsigned-reg) :target res))
+  (:results (res :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:result-types unsigned-num)
+  (:translate (setf floating-point-modes))
+  (:policy :fast-safe)
+  #+nil (:temporary (:sc unsigned-stack) temp)
+  #+nil (:vop-var vop)
+  (:generator 3
+    #+nil
+    (let ((nfp (current-nfp-tn vop)))
+      (storew new nfp (tn-offset temp))
+      (inst ldfsr nfp (* word-bytes (tn-offset temp)))
+      (move res new))
+    (move res new)))