Commit 58c0efd2 authored by cvs2git's avatar cvs2git
Browse files

This commit was manufactured by cvs2svn to create tag 'old_rt'.

parents a8287e33 4716cade
Loading
Loading
Loading
Loading

assembler/assem.lisp

deleted100644 → 0
+0 −697
Original line number Diff line number Diff line
;;; -*- Log: clc.log; Package: Compiler -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice 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 Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************
;;;
;;; Assembler for the Common Lisp Compiler.  This file deals with turning
;;; LAP code into binary code and dumping the results in the right places.
;;; There also ulilities for dealing with the various output files.
;;; 

;;; Written by many hands: Joe Ginder, Scott Fahlman, Dave Dill,
;;; Walter van Roggen, and Skef Wholey.

;;; Currently maintained by Scott Fahlman.

(in-package 'compiler :use '(system))

(import '(lisp::%fasl-code-format))

;;; Version number.

(defparameter assembler-version "2.0")
(defparameter target-fasl-code-format 3)

(proclaim '(special compiler-version target-machine target-system
		    *compile-to-lisp* *lisp-package* *keyword-package*))



(defvar function-name nil
  "Holds a symbol that names the function currently being compiled,
  or nil if between functions.")

;;; Output streams:
;;; If a stream is NIL, don't produce that kind of output.
(defvar *clc-fasl-stream* nil)
(defvar *clc-lap-stream* nil)
(defvar *clc-err-stream* nil)

;;; Stuff we keep track of for the error log:

(defvar functions-with-errors nil
  "A list of all functions that did not compile properly due to errors in
  the code.")

(defvar error-count 0
  "The number of errors generated during this compilation.")

(defvar warning-count 0
  "The number of warnings generated during this compilation.")

(defvar unknown-functions nil
  "List of functions called but not yet seen and not built-in.  The user
  is informed of any function still on this list at the end of a file
  compilation.")

(defvar unknown-free-vars nil
  "A list of all variables referenced free in the compilation, but not
  bound or declared special anywhere.  These are assumed to be special
  variables, but are listed in a warning message at the end of the
  compilation.")

(defvar *verbose* t
  "If nil, only true error messages and warnings go to the error stream.
  If non-null, prints a message as each function is compiled.")

(defvar *compile-to-lisp* nil
  "If non-null, stuff compiled definitions into the compiler's own Lisp
  environment.")

(defvar *clc-input-stream* nil)
(defvar *input-filename* nil "Truename of file being compiled.")
(defvar *compiler-is-reading* nil
  "This is true only if we are actually doing a read from *clc-input-stream*.
  #, (in the reader) looks at this.")

  
;;; The Line-Length of the lap stream...
(defvar *lap-line-length*)

;;; The defined-from string for functions defined in the current source file:
(defvar *current-defined-from*)


;;;; Error Reporting:

;;; CLC-MUMBLE is just a format print to the error stream.

(defun clc-mumble (string &rest args)
  (when *clc-err-stream*
    (apply #'format *clc-err-stream* string args)))


;;; A COMMENT is something the user might like to know, but that will
;;; probably not affect the correctness of his code.

(defun clc-comment (string &rest args)
  (when *clc-err-stream*
    (if (or (not function-name) (eq function-name 'lisp::top-level-form))
	(format *clc-err-stream* "Comment between functions:~%  ")
	(format *clc-err-stream* "Comment in ~S:~%  " function-name))
    (apply #'format *clc-err-stream* string args)
    (terpri *clc-err-stream*)))


;;; A WARNING is something suspicious in the user's code that probably
;;; signals some form of lossage, but that may be ignored if the user
;;; knows what he is doing.

(defun clc-warning (string &rest args)
  (when *clc-err-stream*
    (incf warning-count)
    (if (or (not function-name) (eq function-name 'lisp::top-level-form))
	(format *clc-err-stream* "Warning between functions:~%  ")
	(format *clc-err-stream* "Warning in ~S:~%  " function-name))
    (apply #'format *clc-err-stream* string args)
    (terpri *clc-err-stream*)))


;;; An ERROR is a problem in the user's code that will definitely cause some
;;; lossage.  The compiler attempts to go on with the compilation so that
;;; as many errors as possible can be caught per compilation.

(defun clc-error (string &rest args)
  (when *clc-err-stream*
    (incf error-count)
    (cond ((or (not function-name) (eq function-name 'lisp::top-level-form))
	   (format *clc-err-stream* "Error between functions:~%  ")
	   (pushnew function-name functions-with-errors))
	  (t
	   (format *clc-err-stream* "Error in ~S:~%  " function-name)))
    (apply #'format *clc-err-stream* string args)
    (terpri *clc-err-stream*)))


;;; Keep the internal real and run times in these vars so that we can report
;;; the elapsed time.
(defvar *start-real-time*)
(defvar *start-run-time*)

;;; Start-Assembly  --  Internal
;;;
;;;    This function is called before assembling each batch of stuff.  It
;;; writes out the fasl file header and does other random stuff.  It is
;;; assumed that all the streams are initialized at this point.
;;;
(defun start-assembly ()
  (let* ((host (machine-instance))
	 (now (get-universal-time))
	 (now-string (universal-time-to-string now))
	 (in-string (if *input-filename* (namestring *input-filename*)))
	 (then (if *input-filename*
		   (file-write-date *input-filename*)))
	 (then-string (if then (universal-time-to-string then)))
	 (where (cond ((not *clc-input-stream*)
		       (format nil "Lisp on ~A, machine ~A" now-string host))
		      (in-string
		       (format nil "~A ~A" in-string now-string))
		      ((not then)
		       (format nil "~S on ~A, machine ~A" *clc-input-stream*
			       now-string host))
		      (t
		       (format nil "~A ~A" in-string then-string)))))
    
    ;; Set the defined-from string:
    (setq *current-defined-from* (format nil "~A ~D" where (or then now)))

    (when *input-filename*
      (setq *start-real-time* (get-internal-real-time))
      (setq *start-run-time* (get-internal-run-time))
      (clc-mumble "Error output from ~A.~@
		  Compiled on ~A by CLC version ~A.~2%"
		  where now-string compiler-version))

    (when *clc-lap-stream*
      (setq *lap-line-length* (or (lisp::line-length *clc-lap-stream*) 80))
      (format *clc-lap-stream*
	      "~:[Unreadble~;Readable~] LAP output from ~A.~@
	      Compiled on ~A by CLC version ~A.~%"
	      *print-readable-lap* where now-string compiler-version))
  
    (when *clc-fasl-stream*
      (format *clc-fasl-stream* "FASL FILE output from ~A~@
	      Compiled ~A on ~A~@
	      Compiler ~A, Assembler ~A, Lisp ~A~@
	      Targeted for ~A/~A, FASL code format ~D~%"
	      where now-string host compiler-version assembler-version
	      (lisp-implementation-version) target-machine target-system
	      c::target-fasl-code-format)
      (start-fasl-file))))

;;; Also the ten-dozenth place this is defined...
(defun universal-time-to-string (ut)
  (multiple-value-bind (sec min hour day month year)
		       (decode-universal-time ut)
    (format nil "~D-~A-~2,'0D ~D:~2,'0D:~2,'0D"
	    day (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
			  "Sep" "Oct" "Nov" "Dec")
		       (1- month))
	    (rem year 100)
	    hour min sec)))

(defun elapsed-time-to-string (it)
  (let ((tsec (truncate it internal-time-units-per-second)))
    (multiple-value-bind (tmin sec)
			 (truncate tsec 60)
      (multiple-value-bind (thr min)
			   (truncate tmin 60)
	(format nil "~D:~2,'0D:~2,'0D" thr min sec)))))


;;; Finish-Assembly  --  Internal
;;;
;;;
(defun finish-assembly ()
  (when *clc-fasl-stream* (terminate-fasl-file))
  
  ;; All done.  Let the post-mortems begin.
  (when *input-filename*
    (clc-mumble "~%Finished compilation of file ~S.~%"
		(namestring *input-filename*))
    (clc-mumble "~S Errors, ~S Warnings.~%" error-count warning-count)
    (clc-mumble "Elapsed time ~A, run time ~A.~2%"
		(elapsed-time-to-string (- (get-internal-real-time)
					   *start-real-time*))
		(elapsed-time-to-string (- (get-internal-run-time)
					   *start-run-time*))))
    
  (when functions-with-errors
    (clc-mumble "Errors were detected in the following functions:~% ~S~%"
		(nreverse functions-with-errors)))
  (when unknown-functions
    (clc-mumble
     "These symbols were called as functions but not declared or defined:~% ~S~%"
     (nreverse unknown-functions)))
  (do* ((p NIL)
	(l unknown-free-vars (cdr l))
	(a (car l) (car l)))
       ((null l))
    (if (get a 'globally-special-in-compiler)
	(cond (p (rplacd p (cdr l))
		 (setq l p))
	      (T (setq unknown-free-vars (cdr l))
		 (setq p NIL)))
	(setq p l)))
  (when unknown-free-vars
    (clc-mumble
     "The following variables, assumed to be special, are referenced~@
     but never declared:~% ~S~%"
     (nreverse unknown-free-vars))))

;;;; Fasl dumping stuff:

;;; Next slot to be filled in the fasload table.  Reset at the start of
;;; each new FASL file.
(defvar fop-table-counter 0)

;;; For speed, we keep the table index for each symbol in a property
;;; under that symbol, rather than in an A-list.  All the symbols with
;;; FOP-TABLE-INDEX properties are kept on this list, so that we can
;;; clean up when a new FASL file is started.
(defvar fop-table-symbol-list nil)

;;; FOP-TABLE-PACKAGE-LIST is an a-list mapping packages to their fop-table
;;; indices.  Each entry is (package . index).
(defvar fop-table-package-list nil)

;;; When we dump lists and strings, we look for them in this hashtable.
;;; If we find what we are looking for, we just push the thing from the
;;; table.  If it isn't there, we dump the object and then enter it.
(defvar *table-table* (make-hash-table :test #'equal))

;;; If true, then we must dump stuff so that it neither adds to nor refers
;;; the table.  This is used by the forms which need to be available
;;; at cold load time.
(defvar *hands-off-table* nil)

;;; Dump a single byte to the *CLC-FASL-STREAM* file.  We buffer these until
;;; we collect 512 of them, and then write-string them to the FASL stream.
(defvar *dump-byte-buffer* (make-array 512 :element-type '(mod 256)))
(defvar *dump-byte-index*)


(defun dump-dump-byte-buffer ()
  (write-string *dump-byte-buffer* *clc-fasl-stream*
		:start 0 :end *dump-byte-index*)
  (setq *dump-byte-index* 0))

(defmacro dump-byte (b)
  `(progn
    (if (= *dump-byte-index* 512)
	(dump-dump-byte-buffer))
    (setf (aref *dump-byte-buffer* *dump-byte-index*) (logand ,b #x+FF))
    (incf *dump-byte-index*)))


;;; Put out the code for one FASL-format operator.

(defun dump-fop (fs)
  (let ((val (get fs 'lisp::fop-code)))
    (if (null val)
	(error "Compiler bug: ~S not a legal fasload operator." fs)
	(dump-byte val))))


(defmacro dump-fop* (n byte-fop word-fop)
  `(cond ((< ,n 256)
	  (dump-fop ',byte-fop)
	  (dump-byte ,n))
	 (t
	  (dump-fop ',word-fop)
	  (quick-dump-number ,n 4))))

;;; Dump out number NUM as BYTES bytes.

(defun quick-dump-number (num bytes)
  (do ((n num (ash n -8))
       (i bytes (1- i)))
      ((= i 0))
    (dump-byte (logand n #o377))))

;;; Start-Fasl-File  --  Internal
;;;
;;;    Set up fasdumper state and finish off the header.  The "FASL FILE"
;;; header should already be written.  Called by Start-Assembly.
;;;
(defun start-fasl-file ()
  ;; We now have a virgin FOP-TABLE, so clean up any old stuff.
  (setq fop-table-counter 0)
  ;; Just in case this didn't get cleaned up after an earlier compile.
  (cond (fop-table-symbol-list
	 (do ((sl fop-table-symbol-list (cdr sl)))
	     ((null sl) (setq fop-table-symbol-list nil))
	   (remprop (car sl) 'lisp::fop-table-index))))
  ;; Clear the package alist.
  (setq fop-table-package-list nil)
  ;; And the table hashtable.
  (clrhash *table-table*)
  ;; Reset the dump-byte buffer
  (setq *dump-byte-index* 0)
  ;; Print header stuff.
  (dump-byte 255)
  ;; Perq code format.
  (dump-fop 'lisp::fop-code-format)
  (dump-byte c::target-fasl-code-format))

;;; Terminate-Fasl-File  --  Internal
;;;
;;;    Finish off the current fasl group and clean up.  Called from 
;;; Finish-Assembly.
;;;
(defun terminate-fasl-file ()
  (dump-fop 'lisp::fop-verify-empty-stack)
  (dump-fop 'lisp::fop-verify-table-size)
  (quick-dump-number fop-table-counter 4)
  (dump-fop 'lisp::fop-end-group)
  (dump-dump-byte-buffer)
  (do ((sl fop-table-symbol-list (cdr sl)))
      ((null sl) (setq fop-table-symbol-list nil))
    (remprop (car sl) 'lisp::fop-table-index)))
  
;;; Fasl-Dump-Cold-Load-Form  --  Internal
;;;
;;;    Similar to fasl-dump-form, except that the form is to be evaluated
;;; at cold load time when in cold load.  This is used to dump package
;;; frobbing forms.
;;;
(defun fasl-dump-cold-load-form (form)
  (dump-fop 'lisp::fop-normal-load)
  (let ((*hands-off-table* t))
    (dump-object form))
  (dump-fop 'lisp::fop-eval-for-effect)
  (dump-fop 'lisp::fop-maybe-cold-load))


;;; Dump-Object  -- Internal
;;;
;;;    Dump an object of any type.  This function dispatches to the correct
;;; type-specific dumping function.  Table entry and lookup for non-immediate
;;; objects other than lists and symbols is done here.
;;;
(defun dump-object (x)
  (cond
   ((listp x)
    (cond ((null x)
	   (dump-fop 'lisp::fop-empty-list))
	  ((eq (car x) '%eval-at-load-time)
	   (load-time-eval x))
	  (t
	   (dump-list x))))
   ((symbolp x)
    (if (eq x t) 
	(dump-fop 'lisp::fop-truth)
	(dump-symbol x)))
   ((fixnump x) (dump-integer x))
   ((characterp x) (dump-character x))
   ((typep x 'short-float) (dump-short-float x))
   (t
    ;;
    ;; Look for it in the table; if it is there, push it, otherwise
    ;; dump it.
    (let ((index (gethash x *table-table*)))
      (cond
       ((and index (not *hands-off-table*))
	(dump-fop* index lisp::fop-byte-push lisp::fop-push))
       (t
	(typecase x
	  (vector
	   (cond ((stringp x) (dump-string x))
		 ((subtypep (array-element-type x) '(unsigned-byte 16))
		  (dump-i-vector x))
		 (t
		  (dump-vector x))))
	  (array (dump-array x))
	  (number
	   (etypecase x
	     (ratio (dump-ratio x))
	     (complex (dump-complex x))
;	     (single-float (dump-single-float x))
	     (long-float (dump-long-float x))
	     (integer (dump-integer x))))
	  (compiled-function (dump-function x))
	  (t
	   (clc-error "This object cannot be dumped into a fasl file:~%  ~S" x)
	   (dump-object nil)))
	;;
	;; If wasn't in the table, put it there...
	(unless *hands-off-table*
	  (dump-fop 'lisp::fop-pop)
	  (dump-fop* fop-table-counter lisp::fop-byte-push lisp::fop-push)
	  (setf (gethash x *table-table*) fop-table-counter)
	  (incf fop-table-counter))))))))

;;;; Number Dumping:

;;; Dump a ratio

(defun dump-ratio (x)
  (dump-object (numerator x))
  (dump-object (denominator x))
  (dump-fop 'lisp::fop-ratio))

;;; Or a complex...

(defun dump-complex (x)
  (dump-object (realpart x))
  (dump-object (imagpart x))
  (dump-fop 'lisp::fop-complex))

;;; Dump an integer.

(defun dump-integer (n)
  (let* ((bytes (compute-bytes n)))
    (cond ((= bytes 1)
	   (dump-fop 'lisp::fop-byte-integer)
	   (dump-byte n))
	  ((< bytes 5)
	   (dump-fop 'lisp::fop-word-integer)
	   (quick-dump-number n 4))
	  ((< bytes 256)
	   (dump-fop 'lisp::fop-small-integer)
	   (dump-byte bytes)
	   (quick-dump-number n bytes))
	  (t (dump-fop 'lisp::fop-integer)
	     (quick-dump-number bytes 4)
	     (quick-dump-number n bytes)))))

;;; Compute how many bytes it will take to represent signed integer N.

(defun compute-bytes (n)
  (truncate (+ (integer-length n) 8) 8))

;;;
;;; These two are almost exactly alike, and could easily be the same function.

(defun dump-short-float (x)
  (multiple-value-bind (f exponent sign) (decode-float x)
    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
      (dump-fop 'lisp::fop-float)
      (dump-byte (1+ (integer-length exponent)))
      (quick-dump-number exponent (compute-bytes exponent))
      (dump-byte (1+ (integer-length mantissa)))
      (quick-dump-number mantissa (compute-bytes mantissa)))))

#|
(defun dump-single-float (x)
  (multiple-value-bind (f exponent sign) (decode-float x)
    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
      (dump-fop 'lisp::fop-float)
      (dump-byte (1+ (integer-length exponent)))
      (dump-byte exponent)
      (dump-byte (1+ (integer-length mantissa)))
      (quick-dump-number mantissa (compute-bytes mantissa)))))
|#
;;; For long-floats we're careful that the dumped mantissa actually
;;; has 63 significant bits, so the fasloader can recognize it as such.

(defun dump-long-float (x)
  (multiple-value-bind (f exponent sign) (decode-float x)
    (let ((mantissa (truncate (scale-float (* f sign) (float-precision f)))))
      (dump-fop 'lisp::fop-float)
      (dump-byte (1+ (integer-length exponent)))
      (quick-dump-number exponent (compute-bytes exponent))
      (dump-byte (1+ (integer-length mantissa)))
      (quick-dump-number mantissa (compute-bytes mantissa)))))

;;;; Symbol Dumping:

(defun dump-symbol (s)
  (let ((number (get s 'lisp::fop-table-index)))
    (if (and number (not *hands-off-table*))
	;; Symbol is already in the table.  Just dump the index.
	(dump-fop* number lisp::fop-byte-push lisp::fop-push)
	;; Got to dump the symbol and put it into the table.
	(let* ((pname (symbol-name s))
	       (pname-length (length pname))
	       (pkg (symbol-package s)))
	  (cond ((null pkg)
		 ;; Symbol is uninterned.
		 (dump-fop* pname-length lisp::fop-uninterned-small-symbol-save
			    lisp::fop-uninterned-symbol-save))
		((eq pkg *package*)
		 ;; Symbol is in current default package.  Just dump it.
		 (dump-fop* pname-length lisp::fop-small-symbol-save
			    lisp::fop-symbol-save))
		((eq pkg *lisp-package*)
		 (dump-fop* pname-length lisp::fop-lisp-small-symbol-save
			    lisp::fop-lisp-symbol-save))
		((eq pkg *keyword-package*)
		 ;; Symbol is in current default package.  Just dump it.
		 (dump-fop* pname-length lisp::fop-keyword-small-symbol-save
			    lisp::fop-keyword-symbol-save))
		(t
		 ;; We have to dump this symbol with a package specifier.
		 (let ((entry (assq pkg fop-table-package-list)))
		   ;; Put the package into the table unless it's already there.
		   (unless entry
		     (unless *hands-off-table*
		       (dump-fop 'lisp::fop-normal-load))
		     (dump-string (package-name pkg))
		     (dump-fop 'lisp::fop-package)
		     (dump-fop 'lisp::fop-pop)
		     (unless *hands-off-table*
		       (dump-fop 'lisp::fop-maybe-cold-load))
		     (setq entry (cons pkg fop-table-counter))
		     (push entry fop-table-package-list)
		     (incf fop-table-counter))
		   (setq entry (cdr entry))
		   (cond
		    ((< pname-length 256)
		     (dump-fop* entry
				lisp::fop-small-symbol-in-byte-package-save
				lisp::fop-small-symbol-in-package-save)
		     (dump-byte pname-length))
		    (t
		     (dump-fop* entry
				lisp::fop-symbol-in-byte-package-save
				lisp::fop-symbol-in-package-save)
		     (quick-dump-number pname-length 4))))))
	  ;; Finish dumping the symbol and put it in table.
	  (do ((index 0 (1+ index)))
	      ((= index pname-length))
	    (dump-byte (char-code (schar pname index))))
	  (unless *hands-off-table*
	    (setf (get s 'lisp::fop-table-index) fop-table-counter))
	  (push s fop-table-symbol-list)
	  (setq fop-table-counter (1+ fop-table-counter))))))

;;; Dumper for lists.

(defun dump-list (list)
  (if (null list)
      (dump-fop 'lisp::fop-empty-list)
      (let ((index (gethash list *table-table*)))
	(cond ((and index (not *hands-off-table*))
	       (dump-fop* index lisp::fop-byte-push lisp::fop-push))
	      (t
	       (do ((l list (cdr l))
		    (n 0 (1+ n)))
		   ((atom l)
		    (cond ((null l)
			   (terminate-undotted-list n))
			  (t (dump-object l)
			     (terminate-dotted-list n))))
		 (dump-object (car l)))
	       (unless *hands-off-table*
		 (dump-fop 'lisp::fop-pop)
		 (dump-fop* fop-table-counter lisp::fop-byte-push
			    lisp::fop-push)
		 (setf (gethash list *table-table*) fop-table-counter)
		 (incf fop-table-counter)))))))

(defun terminate-dotted-list (n)
  (case n
    (1 (dump-fop 'lisp::fop-list*-1))
    (2 (dump-fop 'lisp::fop-list*-2))
    (3 (dump-fop 'lisp::fop-list*-3))
    (4 (dump-fop 'lisp::fop-list*-4))
    (5 (dump-fop 'lisp::fop-list*-5))
    (6 (dump-fop 'lisp::fop-list*-6))
    (7 (dump-fop 'lisp::fop-list*-7))
    (8 (dump-fop 'lisp::fop-list*-8))
    (T (do ((nn n (- nn 255)))
	   ((< nn 256)
	    (dump-fop 'lisp::fop-list*)
	    (dump-byte nn))
	 (dump-fop 'lisp::fop-list*)
	 (dump-byte 255)))))

;;; If N > 255, must build list with one list operator, then list* operators.

(defun terminate-undotted-list (n)
    (case n
      (1 (dump-fop 'lisp::fop-list-1))
      (2 (dump-fop 'lisp::fop-list-2))
      (3 (dump-fop 'lisp::fop-list-3))
      (4 (dump-fop 'lisp::fop-list-4))
      (5 (dump-fop 'lisp::fop-list-5))
      (6 (dump-fop 'lisp::fop-list-6))
      (7 (dump-fop 'lisp::fop-list-7))
      (8 (dump-fop 'lisp::fop-list-8))
      (T (cond ((< n 256)
		(dump-fop 'lisp::fop-list)
		(dump-byte n))
	       (t (dump-fop 'lisp::fop-list)
		  (dump-byte 255)
		  (do ((nn (- n 255) (- nn 255)))
		      ((< nn 256)
		       (dump-fop 'lisp::fop-list*)
		       (dump-byte nn))
		    (dump-fop 'lisp::fop-list*)
		    (dump-byte 255)))))))

;;;; Array dumping:

;;; Named G-vectors get their subtype field set at load time.

(defun dump-vector (obj)
  (cond ((and (simple-vector-p obj)
	      (= (%primitive get-vector-subtype obj)
		 %g-vector-structure-subtype))
	 (normal-dump-vector obj)
	 (dump-fop 'lisp::fop-structure))
	(t
	 (normal-dump-vector obj))))

(defun normal-dump-vector (v)
  (do ((index 0 (1+ index))
       (length (length v)))
      ((= index length)
       (dump-fop* length lisp::fop-small-vector lisp::fop-vector))
    (dump-object (aref v index))))

;;; Dump a string.

(defun dump-string (s)
  (let ((length (length s)))
    (dump-fop* length lisp::fop-small-string lisp::fop-string)
    (dotimes (i length)
      (dump-byte (char-code (char s i))))))

;;; Dump-Array  --  Internal
;;;
;;;    Dump a multi-dimensional array.  Someday when we figure out what
;;; a displaced array looks like, we can fix this.
;;;
(defun dump-array (array)
  (unless (zerop (%primitive header-ref array %array-displacement-slot))
    (clc-error "Attempt to dump an array with a displacement, you lose big.")
    (dump-object nil)
    (return-from dump-array nil))

  (let ((rank (array-rank array)))
    (dotimes (i rank)
      (dump-integer (array-dimension array i)))
    (dump-object (%primitive header-ref array %array-data-slot))
    (dump-fop 'lisp::fop-array)
    (quick-dump-number rank 4)))


;;; Dump a character.

(defun dump-character (ch)
  (cond
   ((string-char-p ch)
    (dump-fop 'lisp::fop-short-character)
    (dump-byte (char-code ch)))
   (t
    (dump-fop 'lisp::fop-character)
    (dump-byte (char-code ch))
    (dump-byte (char-bits ch))
    (dump-byte (char-font ch)))))

assembler/assembler.lisp

deleted100644 → 0
+0 −1693

File deleted.

Preview size limit exceeded, changes collapsed.

assembler/disassemble.lisp

deleted100644 → 0
+0 −368

File deleted.

Preview size limit exceeded, changes collapsed.

assembler/miscasm.lisp

deleted100644 → 0
+0 −44
Original line number Diff line number Diff line
;;; -*- Mode: Lisp; Package: Compiler -*-

;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC). 
;;; **********************************************************************

(in-package 'compiler)

(export '(asm asm-files) (find-package 'compiler))

(defun asm (f)
  (assemble-file (concatenate 'simple-string "miscops:" f ".romp")))

(defun asm-files ()
  (asm "abs")
  (asm "allocation")
  (asm "arith")
  (asm "array")
  (asm "byte")
  (asm "call")
  (asm "nlx")
  (asm "compare")
  (asm "divide")
  (asm "gc")
  (asm "gcd")
  (asm "irrat")
  (asm "list")
  (asm "logic")
  (asm "minus")
  (asm "misc")
  (asm "multiply")
  (asm "negate")
  (asm "plus")
  (asm "print")
  (asm "predicate")
  (asm "save")
  (asm "stack")
  (asm "symbol")
  (asm "system")
  (asm "truncate"))

assembler/rompconst.lisp

deleted100644 → 0
+0 −1097

File deleted.

Preview size limit exceeded, changes collapsed.

Loading